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 gcc_assert (se->want_pointer);
484 if (!sym->attr.dummy)
486 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
487 se->expr = build_fold_addr_expr (se->expr);
493 /* Dereference the expression, where needed. Since characters
494 are entirely different from other types, they are treated
496 if (sym->ts.type == BT_CHARACTER)
498 /* Dereference character pointer dummy arguments
500 if ((sym->attr.pointer || sym->attr.allocatable)
502 || sym->attr.function
503 || sym->attr.result))
504 se->expr = build_fold_indirect_ref (se->expr);
507 else if (!sym->attr.value)
509 /* Dereference non-character scalar dummy arguments. */
510 if (sym->attr.dummy && !sym->attr.dimension)
511 se->expr = build_fold_indirect_ref (se->expr);
513 /* Dereference scalar hidden result. */
514 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
515 && (sym->attr.function || sym->attr.result)
516 && !sym->attr.dimension && !sym->attr.pointer
517 && !sym->attr.always_explicit)
518 se->expr = build_fold_indirect_ref (se->expr);
520 /* Dereference non-character pointer variables.
521 These must be dummies, results, or scalars. */
522 if ((sym->attr.pointer || sym->attr.allocatable)
524 || sym->attr.function
526 || !sym->attr.dimension))
527 se->expr = build_fold_indirect_ref (se->expr);
533 /* For character variables, also get the length. */
534 if (sym->ts.type == BT_CHARACTER)
536 /* If the character length of an entry isn't set, get the length from
537 the master function instead. */
538 if (sym->attr.entry && !sym->ts.cl->backend_decl)
539 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
541 se->string_length = sym->ts.cl->backend_decl;
542 gcc_assert (se->string_length);
550 /* Return the descriptor if that's what we want and this is an array
551 section reference. */
552 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
554 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
555 /* Return the descriptor for array pointers and allocations. */
557 && ref->next == NULL && (se->descriptor_only))
560 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
561 /* Return a pointer to an element. */
565 gfc_conv_component_ref (se, ref);
569 gfc_conv_substring (se, ref, expr->ts.kind,
570 expr->symtree->name, &expr->where);
579 /* Pointer assignment, allocation or pass by reference. Arrays are handled
581 if (se->want_pointer)
583 if (expr->ts.type == BT_CHARACTER)
584 gfc_conv_string_parameter (se);
586 se->expr = build_fold_addr_expr (se->expr);
591 /* Unary ops are easy... Or they would be if ! was a valid op. */
594 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
599 gcc_assert (expr->ts.type != BT_CHARACTER);
600 /* Initialize the operand. */
601 gfc_init_se (&operand, se);
602 gfc_conv_expr_val (&operand, expr->value.op.op1);
603 gfc_add_block_to_block (&se->pre, &operand.pre);
605 type = gfc_typenode_for_spec (&expr->ts);
607 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
608 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
609 All other unary operators have an equivalent GIMPLE unary operator. */
610 if (code == TRUTH_NOT_EXPR)
611 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
612 build_int_cst (type, 0));
614 se->expr = fold_build1 (code, type, operand.expr);
618 /* Expand power operator to optimal multiplications when a value is raised
619 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
620 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
621 Programming", 3rd Edition, 1998. */
623 /* This code is mostly duplicated from expand_powi in the backend.
624 We establish the "optimal power tree" lookup table with the defined size.
625 The items in the table are the exponents used to calculate the index
626 exponents. Any integer n less than the value can get an "addition chain",
627 with the first node being one. */
628 #define POWI_TABLE_SIZE 256
630 /* The table is from builtins.c. */
631 static const unsigned char powi_table[POWI_TABLE_SIZE] =
633 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
634 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
635 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
636 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
637 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
638 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
639 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
640 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
641 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
642 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
643 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
644 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
645 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
646 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
647 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
648 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
649 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
650 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
651 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
652 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
653 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
654 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
655 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
656 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
657 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
658 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
659 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
660 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
661 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
662 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
663 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
664 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
667 /* If n is larger than lookup table's max index, we use the "window
669 #define POWI_WINDOW_SIZE 3
671 /* Recursive function to expand the power operator. The temporary
672 values are put in tmpvar. The function returns tmpvar[1] ** n. */
674 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
681 if (n < POWI_TABLE_SIZE)
686 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
687 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
691 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
692 op0 = gfc_conv_powi (se, n - digit, tmpvar);
693 op1 = gfc_conv_powi (se, digit, tmpvar);
697 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
701 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
702 tmp = gfc_evaluate_now (tmp, &se->pre);
704 if (n < POWI_TABLE_SIZE)
711 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
712 return 1. Else return 0 and a call to runtime library functions
713 will have to be built. */
715 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
720 tree vartmp[POWI_TABLE_SIZE];
722 unsigned HOST_WIDE_INT n;
725 /* If exponent is too large, we won't expand it anyway, so don't bother
726 with large integer values. */
727 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
730 m = double_int_to_shwi (TREE_INT_CST (rhs));
731 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
732 of the asymmetric range of the integer type. */
733 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
735 type = TREE_TYPE (lhs);
736 sgn = tree_int_cst_sgn (rhs);
738 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
739 || optimize_size) && (m > 2 || m < -1))
745 se->expr = gfc_build_const (type, integer_one_node);
749 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
750 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
752 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
753 lhs, build_int_cst (TREE_TYPE (lhs), -1));
754 cond = fold_build2 (EQ_EXPR, boolean_type_node,
755 lhs, build_int_cst (TREE_TYPE (lhs), 1));
758 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
761 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
762 se->expr = fold_build3 (COND_EXPR, type,
763 tmp, build_int_cst (type, 1),
764 build_int_cst (type, 0));
768 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
769 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
770 build_int_cst (type, 0));
771 se->expr = fold_build3 (COND_EXPR, type,
772 cond, build_int_cst (type, 1), tmp);
776 memset (vartmp, 0, sizeof (vartmp));
780 tmp = gfc_build_const (type, integer_one_node);
781 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
784 se->expr = gfc_conv_powi (se, n, vartmp);
790 /* Power op (**). Constant integer exponent has special handling. */
793 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
795 tree gfc_int4_type_node;
802 gfc_init_se (&lse, se);
803 gfc_conv_expr_val (&lse, expr->value.op.op1);
804 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
805 gfc_add_block_to_block (&se->pre, &lse.pre);
807 gfc_init_se (&rse, se);
808 gfc_conv_expr_val (&rse, expr->value.op.op2);
809 gfc_add_block_to_block (&se->pre, &rse.pre);
811 if (expr->value.op.op2->ts.type == BT_INTEGER
812 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
813 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
816 gfc_int4_type_node = gfc_get_int_type (4);
818 kind = expr->value.op.op1->ts.kind;
819 switch (expr->value.op.op2->ts.type)
822 ikind = expr->value.op.op2->ts.kind;
827 rse.expr = convert (gfc_int4_type_node, rse.expr);
849 if (expr->value.op.op1->ts.type == BT_INTEGER)
850 lse.expr = convert (gfc_int4_type_node, lse.expr);
875 switch (expr->value.op.op1->ts.type)
878 if (kind == 3) /* Case 16 was not handled properly above. */
880 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
884 /* Use builtins for real ** int4. */
890 fndecl = built_in_decls[BUILT_IN_POWIF];
894 fndecl = built_in_decls[BUILT_IN_POWI];
899 fndecl = built_in_decls[BUILT_IN_POWIL];
907 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
911 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
923 fndecl = built_in_decls[BUILT_IN_POWF];
926 fndecl = built_in_decls[BUILT_IN_POW];
930 fndecl = built_in_decls[BUILT_IN_POWL];
941 fndecl = built_in_decls[BUILT_IN_CPOWF];
944 fndecl = built_in_decls[BUILT_IN_CPOW];
948 fndecl = built_in_decls[BUILT_IN_CPOWL];
960 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
964 /* Generate code to allocate a string temporary. */
967 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
972 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
974 if (gfc_can_put_var_on_stack (len))
976 /* Create a temporary variable to hold the result. */
977 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
978 build_int_cst (gfc_charlen_type_node, 1));
979 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
980 tmp = build_array_type (gfc_character1_type_node, tmp);
981 var = gfc_create_var (tmp, "str");
982 var = gfc_build_addr_expr (type, var);
986 /* Allocate a temporary to hold the result. */
987 var = gfc_create_var (type, "pstr");
988 tmp = gfc_call_malloc (&se->pre, type, len);
989 gfc_add_modify_expr (&se->pre, var, tmp);
991 /* Free the temporary afterwards. */
992 tmp = gfc_call_free (convert (pvoid_type_node, var));
993 gfc_add_expr_to_block (&se->post, tmp);
1000 /* Handle a string concatenation operation. A temporary will be allocated to
1004 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1013 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1014 && expr->value.op.op2->ts.type == BT_CHARACTER);
1016 gfc_init_se (&lse, se);
1017 gfc_conv_expr (&lse, expr->value.op.op1);
1018 gfc_conv_string_parameter (&lse);
1019 gfc_init_se (&rse, se);
1020 gfc_conv_expr (&rse, expr->value.op.op2);
1021 gfc_conv_string_parameter (&rse);
1023 gfc_add_block_to_block (&se->pre, &lse.pre);
1024 gfc_add_block_to_block (&se->pre, &rse.pre);
1026 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1027 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1028 if (len == NULL_TREE)
1030 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1031 lse.string_length, rse.string_length);
1034 type = build_pointer_type (type);
1036 var = gfc_conv_string_tmp (se, type, len);
1038 /* Do the actual concatenation. */
1039 tmp = build_call_expr (gfor_fndecl_concat_string, 6,
1041 lse.string_length, lse.expr,
1042 rse.string_length, rse.expr);
1043 gfc_add_expr_to_block (&se->pre, tmp);
1045 /* Add the cleanup for the operands. */
1046 gfc_add_block_to_block (&se->pre, &rse.post);
1047 gfc_add_block_to_block (&se->pre, &lse.post);
1050 se->string_length = len;
1053 /* Translates an op expression. Common (binary) cases are handled by this
1054 function, others are passed on. Recursion is used in either case.
1055 We use the fact that (op1.ts == op2.ts) (except for the power
1057 Operators need no special handling for scalarized expressions as long as
1058 they call gfc_conv_simple_val to get their operands.
1059 Character strings get special handling. */
1062 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1064 enum tree_code code;
1073 switch (expr->value.op.operator)
1075 case INTRINSIC_PARENTHESES:
1076 if (expr->ts.type == BT_REAL
1077 || expr->ts.type == BT_COMPLEX)
1079 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1080 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1085 case INTRINSIC_UPLUS:
1086 gfc_conv_expr (se, expr->value.op.op1);
1089 case INTRINSIC_UMINUS:
1090 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1094 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1097 case INTRINSIC_PLUS:
1101 case INTRINSIC_MINUS:
1105 case INTRINSIC_TIMES:
1109 case INTRINSIC_DIVIDE:
1110 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1111 an integer, we must round towards zero, so we use a
1113 if (expr->ts.type == BT_INTEGER)
1114 code = TRUNC_DIV_EXPR;
1119 case INTRINSIC_POWER:
1120 gfc_conv_power_op (se, expr);
1123 case INTRINSIC_CONCAT:
1124 gfc_conv_concat_op (se, expr);
1128 code = TRUTH_ANDIF_EXPR;
1133 code = TRUTH_ORIF_EXPR;
1137 /* EQV and NEQV only work on logicals, but since we represent them
1138 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1140 case INTRINSIC_EQ_OS:
1148 case INTRINSIC_NE_OS:
1149 case INTRINSIC_NEQV:
1156 case INTRINSIC_GT_OS:
1163 case INTRINSIC_GE_OS:
1170 case INTRINSIC_LT_OS:
1177 case INTRINSIC_LE_OS:
1183 case INTRINSIC_USER:
1184 case INTRINSIC_ASSIGN:
1185 /* These should be converted into function calls by the frontend. */
1189 fatal_error ("Unknown intrinsic op");
1193 /* The only exception to this is **, which is handled separately anyway. */
1194 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1196 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1200 gfc_init_se (&lse, se);
1201 gfc_conv_expr (&lse, expr->value.op.op1);
1202 gfc_add_block_to_block (&se->pre, &lse.pre);
1205 gfc_init_se (&rse, se);
1206 gfc_conv_expr (&rse, expr->value.op.op2);
1207 gfc_add_block_to_block (&se->pre, &rse.pre);
1211 gfc_conv_string_parameter (&lse);
1212 gfc_conv_string_parameter (&rse);
1214 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1215 rse.string_length, rse.expr);
1216 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1217 gfc_add_block_to_block (&lse.post, &rse.post);
1220 type = gfc_typenode_for_spec (&expr->ts);
1224 /* The result of logical ops is always boolean_type_node. */
1225 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1226 se->expr = convert (type, tmp);
1229 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1231 /* Add the post blocks. */
1232 gfc_add_block_to_block (&se->post, &rse.post);
1233 gfc_add_block_to_block (&se->post, &lse.post);
1236 /* If a string's length is one, we convert it to a single character. */
1239 gfc_to_single_character (tree len, tree str)
1241 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1243 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1244 && TREE_INT_CST_HIGH (len) == 0)
1246 str = fold_convert (pchar_type_node, str);
1247 return build_fold_indirect_ref (str);
1255 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1258 if (sym->backend_decl)
1260 /* This becomes the nominal_type in
1261 function.c:assign_parm_find_data_types. */
1262 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1263 /* This becomes the passed_type in
1264 function.c:assign_parm_find_data_types. C promotes char to
1265 integer for argument passing. */
1266 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1268 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1273 /* If we have a constant character expression, make it into an
1275 if ((*expr)->expr_type == EXPR_CONSTANT)
1280 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1281 if ((*expr)->ts.kind != gfc_c_int_kind)
1283 /* The expr needs to be compatible with a C int. If the
1284 conversion fails, then the 2 causes an ICE. */
1285 ts.type = BT_INTEGER;
1286 ts.kind = gfc_c_int_kind;
1287 gfc_convert_type (*expr, &ts, 2);
1290 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1292 if ((*expr)->ref == NULL)
1294 se->expr = gfc_to_single_character
1295 (build_int_cst (integer_type_node, 1),
1296 gfc_build_addr_expr (pchar_type_node,
1298 ((*expr)->symtree->n.sym)));
1302 gfc_conv_variable (se, *expr);
1303 se->expr = gfc_to_single_character
1304 (build_int_cst (integer_type_node, 1),
1305 gfc_build_addr_expr (pchar_type_node, se->expr));
1312 /* Compare two strings. If they are all single characters, the result is the
1313 subtraction of them. Otherwise, we build a library call. */
1316 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1322 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1323 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1325 sc1 = gfc_to_single_character (len1, str1);
1326 sc2 = gfc_to_single_character (len2, str2);
1328 /* Deal with single character specially. */
1329 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1331 sc1 = fold_convert (integer_type_node, sc1);
1332 sc2 = fold_convert (integer_type_node, sc2);
1333 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1336 /* Build a call for the comparison. */
1337 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1338 len1, str1, len2, str2);
1343 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1347 if (sym->attr.dummy)
1349 tmp = gfc_get_symbol_decl (sym);
1350 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1351 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1355 if (!sym->backend_decl)
1356 sym->backend_decl = gfc_get_extern_function_decl (sym);
1358 tmp = sym->backend_decl;
1359 if (sym->attr.cray_pointee)
1360 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1361 gfc_get_symbol_decl (sym->cp_pointer));
1362 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1364 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1365 tmp = build_fold_addr_expr (tmp);
1372 /* Translate the call for an elemental subroutine call used in an operator
1373 assignment. This is a simplified version of gfc_conv_function_call. */
1376 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1383 /* Only elemental subroutines with two arguments. */
1384 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1385 gcc_assert (sym->formal->next->next == NULL);
1387 gfc_init_block (&block);
1389 gfc_add_block_to_block (&block, &lse->pre);
1390 gfc_add_block_to_block (&block, &rse->pre);
1392 /* Build the argument list for the call, including hidden string lengths. */
1393 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1394 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1395 if (lse->string_length != NULL_TREE)
1396 args = gfc_chainon_list (args, lse->string_length);
1397 if (rse->string_length != NULL_TREE)
1398 args = gfc_chainon_list (args, rse->string_length);
1400 /* Build the function call. */
1401 gfc_init_se (&se, NULL);
1402 gfc_conv_function_val (&se, sym);
1403 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1404 tmp = build_call_list (tmp, se.expr, args);
1405 gfc_add_expr_to_block (&block, tmp);
1407 gfc_add_block_to_block (&block, &lse->post);
1408 gfc_add_block_to_block (&block, &rse->post);
1410 return gfc_finish_block (&block);
1414 /* Initialize MAPPING. */
1417 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1419 mapping->syms = NULL;
1420 mapping->charlens = NULL;
1424 /* Free all memory held by MAPPING (but not MAPPING itself). */
1427 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1429 gfc_interface_sym_mapping *sym;
1430 gfc_interface_sym_mapping *nextsym;
1432 gfc_charlen *nextcl;
1434 for (sym = mapping->syms; sym; sym = nextsym)
1436 nextsym = sym->next;
1437 gfc_free_symbol (sym->new->n.sym);
1438 gfc_free_expr (sym->expr);
1439 gfc_free (sym->new);
1442 for (cl = mapping->charlens; cl; cl = nextcl)
1445 gfc_free_expr (cl->length);
1451 /* Return a copy of gfc_charlen CL. Add the returned structure to
1452 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1454 static gfc_charlen *
1455 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1460 new = gfc_get_charlen ();
1461 new->next = mapping->charlens;
1462 new->length = gfc_copy_expr (cl->length);
1464 mapping->charlens = new;
1469 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1470 array variable that can be used as the actual argument for dummy
1471 argument SYM. Add any initialization code to BLOCK. PACKED is as
1472 for gfc_get_nodesc_array_type and DATA points to the first element
1473 in the passed array. */
1476 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1477 gfc_packed packed, tree data)
1482 type = gfc_typenode_for_spec (&sym->ts);
1483 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1485 var = gfc_create_var (type, "ifm");
1486 gfc_add_modify_expr (block, var, fold_convert (type, data));
1492 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1493 and offset of descriptorless array type TYPE given that it has the same
1494 size as DESC. Add any set-up code to BLOCK. */
1497 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1504 offset = gfc_index_zero_node;
1505 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1507 dim = gfc_rank_cst[n];
1508 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1509 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1511 GFC_TYPE_ARRAY_LBOUND (type, n)
1512 = gfc_conv_descriptor_lbound (desc, dim);
1513 GFC_TYPE_ARRAY_UBOUND (type, n)
1514 = gfc_conv_descriptor_ubound (desc, dim);
1516 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1518 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1519 gfc_conv_descriptor_ubound (desc, dim),
1520 gfc_conv_descriptor_lbound (desc, dim));
1521 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1522 GFC_TYPE_ARRAY_LBOUND (type, n),
1524 tmp = gfc_evaluate_now (tmp, block);
1525 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1527 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1528 GFC_TYPE_ARRAY_LBOUND (type, n),
1529 GFC_TYPE_ARRAY_STRIDE (type, n));
1530 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1532 offset = gfc_evaluate_now (offset, block);
1533 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1537 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1538 in SE. The caller may still use se->expr and se->string_length after
1539 calling this function. */
1542 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1543 gfc_symbol * sym, gfc_se * se,
1546 gfc_interface_sym_mapping *sm;
1550 gfc_symbol *new_sym;
1552 gfc_symtree *new_symtree;
1554 /* Create a new symbol to represent the actual argument. */
1555 new_sym = gfc_new_symbol (sym->name, NULL);
1556 new_sym->ts = sym->ts;
1557 new_sym->attr.referenced = 1;
1558 new_sym->attr.dimension = sym->attr.dimension;
1559 new_sym->attr.pointer = sym->attr.pointer;
1560 new_sym->attr.allocatable = sym->attr.allocatable;
1561 new_sym->attr.flavor = sym->attr.flavor;
1562 new_sym->attr.function = sym->attr.function;
1564 /* Create a fake symtree for it. */
1566 new_symtree = gfc_new_symtree (&root, sym->name);
1567 new_symtree->n.sym = new_sym;
1568 gcc_assert (new_symtree == root);
1570 /* Create a dummy->actual mapping. */
1571 sm = gfc_getmem (sizeof (*sm));
1572 sm->next = mapping->syms;
1574 sm->new = new_symtree;
1575 sm->expr = gfc_copy_expr (expr);
1578 /* Stabilize the argument's value. */
1579 if (!sym->attr.function && se)
1580 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1582 if (sym->ts.type == BT_CHARACTER)
1584 /* Create a copy of the dummy argument's length. */
1585 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1586 sm->expr->ts.cl = new_sym->ts.cl;
1588 /* If the length is specified as "*", record the length that
1589 the caller is passing. We should use the callee's length
1590 in all other cases. */
1591 if (!new_sym->ts.cl->length && se)
1593 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1594 new_sym->ts.cl->backend_decl = se->string_length;
1601 /* Use the passed value as-is if the argument is a function. */
1602 if (sym->attr.flavor == FL_PROCEDURE)
1605 /* If the argument is either a string or a pointer to a string,
1606 convert it to a boundless character type. */
1607 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1609 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1610 tmp = build_pointer_type (tmp);
1611 if (sym->attr.pointer)
1612 value = build_fold_indirect_ref (se->expr);
1615 value = fold_convert (tmp, value);
1618 /* If the argument is a scalar, a pointer to an array or an allocatable,
1620 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1621 value = build_fold_indirect_ref (se->expr);
1623 /* For character(*), use the actual argument's descriptor. */
1624 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1625 value = build_fold_indirect_ref (se->expr);
1627 /* If the argument is an array descriptor, use it to determine
1628 information about the actual argument's shape. */
1629 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1630 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1632 /* Get the actual argument's descriptor. */
1633 desc = build_fold_indirect_ref (se->expr);
1635 /* Create the replacement variable. */
1636 tmp = gfc_conv_descriptor_data_get (desc);
1637 value = gfc_get_interface_mapping_array (&se->pre, sym,
1640 /* Use DESC to work out the upper bounds, strides and offset. */
1641 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1644 /* Otherwise we have a packed array. */
1645 value = gfc_get_interface_mapping_array (&se->pre, sym,
1646 PACKED_FULL, se->expr);
1648 new_sym->backend_decl = value;
1652 /* Called once all dummy argument mappings have been added to MAPPING,
1653 but before the mapping is used to evaluate expressions. Pre-evaluate
1654 the length of each argument, adding any initialization code to PRE and
1655 any finalization code to POST. */
1658 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1659 stmtblock_t * pre, stmtblock_t * post)
1661 gfc_interface_sym_mapping *sym;
1665 for (sym = mapping->syms; sym; sym = sym->next)
1666 if (sym->new->n.sym->ts.type == BT_CHARACTER
1667 && !sym->new->n.sym->ts.cl->backend_decl)
1669 expr = sym->new->n.sym->ts.cl->length;
1670 gfc_apply_interface_mapping_to_expr (mapping, expr);
1671 gfc_init_se (&se, NULL);
1672 gfc_conv_expr (&se, expr);
1674 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1675 gfc_add_block_to_block (pre, &se.pre);
1676 gfc_add_block_to_block (post, &se.post);
1678 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1683 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1687 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1688 gfc_constructor * c)
1690 for (; c; c = c->next)
1692 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1695 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1696 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1697 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1703 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1707 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1712 for (; ref; ref = ref->next)
1716 for (n = 0; n < ref->u.ar.dimen; n++)
1718 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1719 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1720 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1722 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1729 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1730 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1736 /* Convert intrinsic function calls into result expressions. */
1738 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
1746 arg1 = expr->value.function.actual->expr;
1747 if (expr->value.function.actual->next)
1748 arg2 = expr->value.function.actual->next->expr;
1752 sym = arg1->symtree->n.sym;
1754 if (sym->attr.dummy)
1759 switch (expr->value.function.isym->id)
1762 /* TODO figure out why this condition is necessary. */
1763 if (sym->attr.function
1764 && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
1765 && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
1768 new_expr = gfc_copy_expr (arg1->ts.cl->length);
1775 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1777 dup = mpz_get_si (arg2->value.integer);
1782 dup = sym->as->rank;
1786 for (; d < dup; d++)
1789 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1790 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1792 new_expr = gfc_multiply (new_expr, tmp);
1798 case GFC_ISYM_LBOUND:
1799 case GFC_ISYM_UBOUND:
1800 /* TODO These implementations of lbound and ubound do not limit if
1801 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1806 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1807 d = mpz_get_si (arg2->value.integer) - 1;
1809 /* TODO: If the need arises, this could produce an array of
1813 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1814 new_expr = gfc_copy_expr (sym->as->lower[d]);
1816 new_expr = gfc_copy_expr (sym->as->upper[d]);
1823 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
1827 gfc_replace_expr (expr, new_expr);
1833 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
1834 gfc_interface_mapping * mapping)
1836 gfc_formal_arglist *f;
1837 gfc_actual_arglist *actual;
1839 actual = expr->value.function.actual;
1840 f = map_expr->symtree->n.sym->formal;
1842 for (; f && actual; f = f->next, actual = actual->next)
1847 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
1850 if (map_expr->symtree->n.sym->attr.dimension)
1855 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
1857 for (d = 0; d < as->rank; d++)
1859 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
1860 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
1863 expr->value.function.esym->as = as;
1866 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
1868 expr->value.function.esym->ts.cl->length
1869 = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
1871 gfc_apply_interface_mapping_to_expr (mapping,
1872 expr->value.function.esym->ts.cl->length);
1877 /* EXPR is a copy of an expression that appeared in the interface
1878 associated with MAPPING. Walk it recursively looking for references to
1879 dummy arguments that MAPPING maps to actual arguments. Replace each such
1880 reference with a reference to the associated actual argument. */
1883 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1886 gfc_interface_sym_mapping *sym;
1887 gfc_actual_arglist *actual;
1892 /* Copying an expression does not copy its length, so do that here. */
1893 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1895 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1896 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1899 /* Apply the mapping to any references. */
1900 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1902 /* ...and to the expression's symbol, if it has one. */
1903 /* TODO Find out why the condition on expr->symtree had to be moved into
1904 the loop rather than being ouside it, as originally. */
1905 for (sym = mapping->syms; sym; sym = sym->next)
1906 if (expr->symtree && sym->old == expr->symtree->n.sym)
1908 if (sym->new->n.sym->backend_decl)
1909 expr->symtree = sym->new;
1911 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
1914 /* ...and to subexpressions in expr->value. */
1915 switch (expr->expr_type)
1920 case EXPR_SUBSTRING:
1924 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1925 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1929 for (actual = expr->value.function.actual; actual; actual = actual->next)
1930 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1932 if (expr->value.function.esym == NULL
1933 && expr->value.function.isym != NULL
1934 && expr->value.function.actual->expr->symtree
1935 && gfc_map_intrinsic_function (expr, mapping))
1938 for (sym = mapping->syms; sym; sym = sym->next)
1939 if (sym->old == expr->value.function.esym)
1941 expr->value.function.esym = sym->new->n.sym;
1942 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
1943 expr->value.function.esym->result = sym->new->n.sym;
1948 case EXPR_STRUCTURE:
1949 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1957 /* Evaluate interface expression EXPR using MAPPING. Store the result
1961 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1962 gfc_se * se, gfc_expr * expr)
1964 expr = gfc_copy_expr (expr);
1965 gfc_apply_interface_mapping_to_expr (mapping, expr);
1966 gfc_conv_expr (se, expr);
1967 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1968 gfc_free_expr (expr);
1972 /* Returns a reference to a temporary array into which a component of
1973 an actual argument derived type array is copied and then returned
1974 after the function call. */
1976 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
1977 int g77, sym_intent intent)
1993 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1995 gfc_init_se (&lse, NULL);
1996 gfc_init_se (&rse, NULL);
1998 /* Walk the argument expression. */
1999 rss = gfc_walk_expr (expr);
2001 gcc_assert (rss != gfc_ss_terminator);
2003 /* Initialize the scalarizer. */
2004 gfc_init_loopinfo (&loop);
2005 gfc_add_ss_to_loop (&loop, rss);
2007 /* Calculate the bounds of the scalarization. */
2008 gfc_conv_ss_startstride (&loop);
2010 /* Build an ss for the temporary. */
2011 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2012 gfc_conv_string_length (expr->ts.cl, &parmse->pre);
2014 base_type = gfc_typenode_for_spec (&expr->ts);
2015 if (GFC_ARRAY_TYPE_P (base_type)
2016 || GFC_DESCRIPTOR_TYPE_P (base_type))
2017 base_type = gfc_get_element_type (base_type);
2019 loop.temp_ss = gfc_get_ss ();;
2020 loop.temp_ss->type = GFC_SS_TEMP;
2021 loop.temp_ss->data.temp.type = base_type;
2023 if (expr->ts.type == BT_CHARACTER)
2024 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2026 loop.temp_ss->string_length = NULL;
2028 parmse->string_length = loop.temp_ss->string_length;
2029 loop.temp_ss->data.temp.dimen = loop.dimen;
2030 loop.temp_ss->next = gfc_ss_terminator;
2032 /* Associate the SS with the loop. */
2033 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2035 /* Setup the scalarizing loops. */
2036 gfc_conv_loop_setup (&loop);
2038 /* Pass the temporary descriptor back to the caller. */
2039 info = &loop.temp_ss->data.info;
2040 parmse->expr = info->descriptor;
2042 /* Setup the gfc_se structures. */
2043 gfc_copy_loopinfo_to_se (&lse, &loop);
2044 gfc_copy_loopinfo_to_se (&rse, &loop);
2047 lse.ss = loop.temp_ss;
2048 gfc_mark_ss_chain_used (rss, 1);
2049 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2051 /* Start the scalarized loop body. */
2052 gfc_start_scalarized_body (&loop, &body);
2054 /* Translate the expression. */
2055 gfc_conv_expr (&rse, expr);
2057 gfc_conv_tmp_array_ref (&lse);
2058 gfc_advance_se_ss_chain (&lse);
2060 if (intent != INTENT_OUT)
2062 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2063 gfc_add_expr_to_block (&body, tmp);
2064 gcc_assert (rse.ss == gfc_ss_terminator);
2065 gfc_trans_scalarizing_loops (&loop, &body);
2069 /* Make sure that the temporary declaration survives by merging
2070 all the loop declarations into the current context. */
2071 for (n = 0; n < loop.dimen; n++)
2073 gfc_merge_block_scope (&body);
2074 body = loop.code[loop.order[n]];
2076 gfc_merge_block_scope (&body);
2079 /* Add the post block after the second loop, so that any
2080 freeing of allocated memory is done at the right time. */
2081 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2083 /**********Copy the temporary back again.*********/
2085 gfc_init_se (&lse, NULL);
2086 gfc_init_se (&rse, NULL);
2088 /* Walk the argument expression. */
2089 lss = gfc_walk_expr (expr);
2090 rse.ss = loop.temp_ss;
2093 /* Initialize the scalarizer. */
2094 gfc_init_loopinfo (&loop2);
2095 gfc_add_ss_to_loop (&loop2, lss);
2097 /* Calculate the bounds of the scalarization. */
2098 gfc_conv_ss_startstride (&loop2);
2100 /* Setup the scalarizing loops. */
2101 gfc_conv_loop_setup (&loop2);
2103 gfc_copy_loopinfo_to_se (&lse, &loop2);
2104 gfc_copy_loopinfo_to_se (&rse, &loop2);
2106 gfc_mark_ss_chain_used (lss, 1);
2107 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2109 /* Declare the variable to hold the temporary offset and start the
2110 scalarized loop body. */
2111 offset = gfc_create_var (gfc_array_index_type, NULL);
2112 gfc_start_scalarized_body (&loop2, &body);
2114 /* Build the offsets for the temporary from the loop variables. The
2115 temporary array has lbounds of zero and strides of one in all
2116 dimensions, so this is very simple. The offset is only computed
2117 outside the innermost loop, so the overall transfer could be
2118 optimized further. */
2119 info = &rse.ss->data.info;
2121 tmp_index = gfc_index_zero_node;
2122 for (n = info->dimen - 1; n > 0; n--)
2125 tmp = rse.loop->loopvar[n];
2126 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2127 tmp, rse.loop->from[n]);
2128 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2131 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2132 rse.loop->to[n-1], rse.loop->from[n-1]);
2133 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2134 tmp_str, gfc_index_one_node);
2136 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2140 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2141 tmp_index, rse.loop->from[0]);
2142 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
2144 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2145 rse.loop->loopvar[0], offset);
2147 /* Now use the offset for the reference. */
2148 tmp = build_fold_indirect_ref (info->data);
2149 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2151 if (expr->ts.type == BT_CHARACTER)
2152 rse.string_length = expr->ts.cl->backend_decl;
2154 gfc_conv_expr (&lse, expr);
2156 gcc_assert (lse.ss == gfc_ss_terminator);
2158 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2159 gfc_add_expr_to_block (&body, tmp);
2161 /* Generate the copying loops. */
2162 gfc_trans_scalarizing_loops (&loop2, &body);
2164 /* Wrap the whole thing up by adding the second loop to the post-block
2165 and following it by the post-block of the first loop. In this way,
2166 if the temporary needs freeing, it is done after use! */
2167 if (intent != INTENT_IN)
2169 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2170 gfc_add_block_to_block (&parmse->post, &loop2.post);
2173 gfc_add_block_to_block (&parmse->post, &loop.post);
2175 gfc_cleanup_loop (&loop);
2176 gfc_cleanup_loop (&loop2);
2178 /* Pass the string length to the argument expression. */
2179 if (expr->ts.type == BT_CHARACTER)
2180 parmse->string_length = expr->ts.cl->backend_decl;
2182 /* We want either the address for the data or the address of the descriptor,
2183 depending on the mode of passing array arguments. */
2185 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2187 parmse->expr = build_fold_addr_expr (parmse->expr);
2193 /* Generate the code for argument list functions. */
2196 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2198 /* Pass by value for g77 %VAL(arg), pass the address
2199 indirectly for %LOC, else by reference. Thus %REF
2200 is a "do-nothing" and %LOC is the same as an F95
2202 if (strncmp (name, "%VAL", 4) == 0)
2203 gfc_conv_expr (se, expr);
2204 else if (strncmp (name, "%LOC", 4) == 0)
2206 gfc_conv_expr_reference (se, expr);
2207 se->expr = gfc_build_addr_expr (NULL, se->expr);
2209 else if (strncmp (name, "%REF", 4) == 0)
2210 gfc_conv_expr_reference (se, expr);
2212 gfc_error ("Unknown argument list function at %L", &expr->where);
2216 /* Generate code for a procedure call. Note can return se->post != NULL.
2217 If se->direct_byref is set then se->expr contains the return parameter.
2218 Return nonzero, if the call has alternate specifiers. */
2221 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2222 gfc_actual_arglist * arg, tree append_args)
2224 gfc_interface_mapping mapping;
2238 gfc_formal_arglist *formal;
2239 int has_alternate_specifier = 0;
2240 bool need_interface_mapping;
2247 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2249 arglist = NULL_TREE;
2250 retargs = NULL_TREE;
2251 stringargs = NULL_TREE;
2256 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2258 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2260 if (arg->expr->rank == 0)
2261 gfc_conv_expr_reference (se, arg->expr);
2265 /* This is really the actual arg because no formal arglist is
2266 created for C_LOC. */
2267 fsym = arg->expr->symtree->n.sym;
2269 /* We should want it to do g77 calling convention. */
2271 && !(fsym->attr.pointer || fsym->attr.allocatable)
2272 && fsym->as->type != AS_ASSUMED_SHAPE;
2273 f = f || !sym->attr.always_explicit;
2275 argss = gfc_walk_expr (arg->expr);
2276 gfc_conv_array_parameter (se, arg->expr, argss, f);
2279 /* TODO -- the following two lines shouldn't be necessary, but
2280 they're removed a bug is exposed later in the codepath.
2281 This is workaround was thus introduced, but will have to be
2282 removed; please see PR 35150 for details about the issue. */
2283 se->expr = convert (pvoid_type_node, se->expr);
2284 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2288 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2290 arg->expr->ts.type = sym->ts.derived->ts.type;
2291 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2292 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2293 gfc_conv_expr_reference (se, arg->expr);
2297 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2302 /* Build the addr_expr for the first argument. The argument is
2303 already an *address* so we don't need to set want_pointer in
2305 gfc_init_se (&arg1se, NULL);
2306 gfc_conv_expr (&arg1se, arg->expr);
2307 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2308 gfc_add_block_to_block (&se->post, &arg1se.post);
2310 /* See if we were given two arguments. */
2311 if (arg->next == NULL)
2312 /* Only given one arg so generate a null and do a
2313 not-equal comparison against the first arg. */
2314 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2315 fold_convert (TREE_TYPE (arg1se.expr),
2316 null_pointer_node));
2322 /* Given two arguments so build the arg2se from second arg. */
2323 gfc_init_se (&arg2se, NULL);
2324 gfc_conv_expr (&arg2se, arg->next->expr);
2325 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2326 gfc_add_block_to_block (&se->post, &arg2se.post);
2328 /* Generate test to compare that the two args are equal. */
2329 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2330 arg1se.expr, arg2se.expr);
2331 /* Generate test to ensure that the first arg is not null. */
2332 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2333 arg1se.expr, null_pointer_node);
2335 /* Finally, the generated test must check that both arg1 is not
2336 NULL and that it is equal to the second arg. */
2337 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2338 not_null_expr, eq_expr);
2347 if (!sym->attr.elemental)
2349 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2350 if (se->ss->useflags)
2352 gcc_assert (gfc_return_by_reference (sym)
2353 && sym->result->attr.dimension);
2354 gcc_assert (se->loop != NULL);
2356 /* Access the previously obtained result. */
2357 gfc_conv_tmp_array_ref (se);
2358 gfc_advance_se_ss_chain (se);
2362 info = &se->ss->data.info;
2367 gfc_init_block (&post);
2368 gfc_init_interface_mapping (&mapping);
2369 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2370 && sym->ts.cl->length
2371 && sym->ts.cl->length->expr_type
2373 || sym->attr.dimension);
2374 formal = sym->formal;
2375 /* Evaluate the arguments. */
2376 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2379 fsym = formal ? formal->sym : NULL;
2380 parm_kind = MISSING;
2384 if (se->ignore_optional)
2386 /* Some intrinsics have already been resolved to the correct
2390 else if (arg->label)
2392 has_alternate_specifier = 1;
2397 /* Pass a NULL pointer for an absent arg. */
2398 gfc_init_se (&parmse, NULL);
2399 parmse.expr = null_pointer_node;
2400 if (arg->missing_arg_type == BT_CHARACTER)
2401 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2404 else if (se->ss && se->ss->useflags)
2406 /* An elemental function inside a scalarized loop. */
2407 gfc_init_se (&parmse, se);
2408 gfc_conv_expr_reference (&parmse, e);
2409 parm_kind = ELEMENTAL;
2413 /* A scalar or transformational function. */
2414 gfc_init_se (&parmse, NULL);
2415 argss = gfc_walk_expr (e);
2417 if (argss == gfc_ss_terminator)
2419 if (fsym && fsym->attr.value)
2421 if (fsym->ts.type == BT_CHARACTER
2422 && fsym->ts.is_c_interop
2423 && fsym->ns->proc_name != NULL
2424 && fsym->ns->proc_name->attr.is_bind_c)
2427 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2428 if (parmse.expr == NULL)
2429 gfc_conv_expr (&parmse, e);
2432 gfc_conv_expr (&parmse, e);
2434 else if (arg->name && arg->name[0] == '%')
2435 /* Argument list functions %VAL, %LOC and %REF are signalled
2436 through arg->name. */
2437 conv_arglist_function (&parmse, arg->expr, arg->name);
2438 else if ((e->expr_type == EXPR_FUNCTION)
2439 && e->symtree->n.sym->attr.pointer
2440 && fsym && fsym->attr.target)
2442 gfc_conv_expr (&parmse, e);
2443 parmse.expr = build_fold_addr_expr (parmse.expr);
2447 gfc_conv_expr_reference (&parmse, e);
2448 if (fsym && fsym->attr.pointer
2449 && fsym->attr.flavor != FL_PROCEDURE
2450 && e->expr_type != EXPR_NULL)
2452 /* Scalar pointer dummy args require an extra level of
2453 indirection. The null pointer already contains
2454 this level of indirection. */
2455 parm_kind = SCALAR_POINTER;
2456 parmse.expr = build_fold_addr_expr (parmse.expr);
2462 /* If the procedure requires an explicit interface, the actual
2463 argument is passed according to the corresponding formal
2464 argument. If the corresponding formal argument is a POINTER,
2465 ALLOCATABLE or assumed shape, we do not use g77's calling
2466 convention, and pass the address of the array descriptor
2467 instead. Otherwise we use g77's calling convention. */
2470 && !(fsym->attr.pointer || fsym->attr.allocatable)
2471 && fsym->as->type != AS_ASSUMED_SHAPE;
2472 f = f || !sym->attr.always_explicit;
2474 if (e->expr_type == EXPR_VARIABLE
2475 && is_subref_array (e))
2476 /* The actual argument is a component reference to an
2477 array of derived types. In this case, the argument
2478 is converted to a temporary, which is passed and then
2479 written back after the procedure call. */
2480 gfc_conv_subref_array_arg (&parmse, e, f,
2481 fsym ? fsym->attr.intent : INTENT_INOUT);
2483 gfc_conv_array_parameter (&parmse, e, argss, f);
2485 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2486 allocated on entry, it must be deallocated. */
2487 if (fsym && fsym->attr.allocatable
2488 && fsym->attr.intent == INTENT_OUT)
2490 tmp = build_fold_indirect_ref (parmse.expr);
2491 tmp = gfc_trans_dealloc_allocated (tmp);
2492 gfc_add_expr_to_block (&se->pre, tmp);
2498 /* The case with fsym->attr.optional is that of a user subroutine
2499 with an interface indicating an optional argument. When we call
2500 an intrinsic subroutine, however, fsym is NULL, but we might still
2501 have an optional argument, so we proceed to the substitution
2503 if (e && (fsym == NULL || fsym->attr.optional))
2505 /* If an optional argument is itself an optional dummy argument,
2506 check its presence and substitute a null if absent. */
2507 if (e->expr_type == EXPR_VARIABLE
2508 && e->symtree->n.sym->attr.optional)
2509 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2510 e->representation.length);
2515 /* Obtain the character length of an assumed character length
2516 length procedure from the typespec. */
2517 if (fsym->ts.type == BT_CHARACTER
2518 && parmse.string_length == NULL_TREE
2519 && e->ts.type == BT_PROCEDURE
2520 && e->symtree->n.sym->ts.type == BT_CHARACTER
2521 && e->symtree->n.sym->ts.cl->length != NULL)
2523 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2524 parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2528 if (fsym && need_interface_mapping && e)
2529 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2531 gfc_add_block_to_block (&se->pre, &parmse.pre);
2532 gfc_add_block_to_block (&post, &parmse.post);
2534 /* Allocated allocatable components of derived types must be
2535 deallocated for INTENT(OUT) dummy arguments and non-variable
2536 scalars. Non-variable arrays are dealt with in trans-array.c
2537 (gfc_conv_array_parameter). */
2538 if (e && e->ts.type == BT_DERIVED
2539 && e->ts.derived->attr.alloc_comp
2540 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2542 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2545 tmp = build_fold_indirect_ref (parmse.expr);
2546 parm_rank = e->rank;
2554 case (SCALAR_POINTER):
2555 tmp = build_fold_indirect_ref (tmp);
2562 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2563 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2564 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2565 tmp, build_empty_stmt ());
2567 if (e->expr_type != EXPR_VARIABLE)
2568 /* Don't deallocate non-variables until they have been used. */
2569 gfc_add_expr_to_block (&se->post, tmp);
2572 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2573 gfc_add_expr_to_block (&se->pre, tmp);
2577 /* Character strings are passed as two parameters, a length and a
2578 pointer - except for Bind(c) which only passes the pointer. */
2579 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2580 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2582 arglist = gfc_chainon_list (arglist, parmse.expr);
2584 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2587 if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2589 if (sym->ts.cl->length == NULL)
2591 /* Assumed character length results are not allowed by 5.1.1.5 of the
2592 standard and are trapped in resolve.c; except in the case of SPREAD
2593 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2594 we take the character length of the first argument for the result.
2595 For dummies, we have to look through the formal argument list for
2596 this function and use the character length found there.*/
2597 if (!sym->attr.dummy)
2598 cl.backend_decl = TREE_VALUE (stringargs);
2601 formal = sym->ns->proc_name->formal;
2602 for (; formal; formal = formal->next)
2603 if (strcmp (formal->sym->name, sym->name) == 0)
2604 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2611 /* Calculate the length of the returned string. */
2612 gfc_init_se (&parmse, NULL);
2613 if (need_interface_mapping)
2614 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2616 gfc_conv_expr (&parmse, sym->ts.cl->length);
2617 gfc_add_block_to_block (&se->pre, &parmse.pre);
2618 gfc_add_block_to_block (&se->post, &parmse.post);
2620 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2621 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2622 build_int_cst (gfc_charlen_type_node, 0));
2623 cl.backend_decl = tmp;
2626 /* Set up a charlen structure for it. */
2631 len = cl.backend_decl;
2634 byref = gfc_return_by_reference (sym);
2637 if (se->direct_byref)
2639 /* Sometimes, too much indirection can be applied; eg. for
2640 function_result = array_valued_recursive_function. */
2641 if (TREE_TYPE (TREE_TYPE (se->expr))
2642 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2643 && GFC_DESCRIPTOR_TYPE_P
2644 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2645 se->expr = build_fold_indirect_ref (se->expr);
2647 retargs = gfc_chainon_list (retargs, se->expr);
2649 else if (sym->result->attr.dimension)
2651 gcc_assert (se->loop && info);
2653 /* Set the type of the array. */
2654 tmp = gfc_typenode_for_spec (&ts);
2655 info->dimen = se->loop->dimen;
2657 /* Evaluate the bounds of the result, if known. */
2658 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2660 /* Create a temporary to store the result. In case the function
2661 returns a pointer, the temporary will be a shallow copy and
2662 mustn't be deallocated. */
2663 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2664 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2665 false, !sym->attr.pointer, callee_alloc);
2667 /* Pass the temporary as the first argument. */
2668 tmp = info->descriptor;
2669 tmp = build_fold_addr_expr (tmp);
2670 retargs = gfc_chainon_list (retargs, tmp);
2672 else if (ts.type == BT_CHARACTER)
2674 /* Pass the string length. */
2675 type = gfc_get_character_type (ts.kind, ts.cl);
2676 type = build_pointer_type (type);
2678 /* Return an address to a char[0:len-1]* temporary for
2679 character pointers. */
2680 if (sym->attr.pointer || sym->attr.allocatable)
2682 var = gfc_create_var (type, "pstr");
2684 /* Provide an address expression for the function arguments. */
2685 var = build_fold_addr_expr (var);
2688 var = gfc_conv_string_tmp (se, type, len);
2690 retargs = gfc_chainon_list (retargs, var);
2694 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2696 type = gfc_get_complex_type (ts.kind);
2697 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2698 retargs = gfc_chainon_list (retargs, var);
2701 /* Add the string length to the argument list. */
2702 if (ts.type == BT_CHARACTER)
2703 retargs = gfc_chainon_list (retargs, len);
2705 gfc_free_interface_mapping (&mapping);
2707 /* Add the return arguments. */
2708 arglist = chainon (retargs, arglist);
2710 /* Add the hidden string length parameters to the arguments. */
2711 arglist = chainon (arglist, stringargs);
2713 /* We may want to append extra arguments here. This is used e.g. for
2714 calls to libgfortran_matmul_??, which need extra information. */
2715 if (append_args != NULL_TREE)
2716 arglist = chainon (arglist, append_args);
2718 /* Generate the actual call. */
2719 gfc_conv_function_val (se, sym);
2721 /* If there are alternate return labels, function type should be
2722 integer. Can't modify the type in place though, since it can be shared
2723 with other functions. For dummy arguments, the typing is done to
2724 to this result, even if it has to be repeated for each call. */
2725 if (has_alternate_specifier
2726 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2728 if (!sym->attr.dummy)
2730 TREE_TYPE (sym->backend_decl)
2731 = build_function_type (integer_type_node,
2732 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2733 se->expr = build_fold_addr_expr (sym->backend_decl);
2736 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2739 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2740 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2742 /* If we have a pointer function, but we don't want a pointer, e.g.
2745 where f is pointer valued, we have to dereference the result. */
2746 if (!se->want_pointer && !byref && sym->attr.pointer)
2747 se->expr = build_fold_indirect_ref (se->expr);
2749 /* f2c calling conventions require a scalar default real function to
2750 return a double precision result. Convert this back to default
2751 real. We only care about the cases that can happen in Fortran 77.
2753 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2754 && sym->ts.kind == gfc_default_real_kind
2755 && !sym->attr.always_explicit)
2756 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2758 /* A pure function may still have side-effects - it may modify its
2760 TREE_SIDE_EFFECTS (se->expr) = 1;
2762 if (!sym->attr.pure)
2763 TREE_SIDE_EFFECTS (se->expr) = 1;
2768 /* Add the function call to the pre chain. There is no expression. */
2769 gfc_add_expr_to_block (&se->pre, se->expr);
2770 se->expr = NULL_TREE;
2772 if (!se->direct_byref)
2774 if (sym->attr.dimension)
2776 if (flag_bounds_check)
2778 /* Check the data pointer hasn't been modified. This would
2779 happen in a function returning a pointer. */
2780 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2781 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2783 gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
2785 se->expr = info->descriptor;
2786 /* Bundle in the string length. */
2787 se->string_length = len;
2789 else if (sym->ts.type == BT_CHARACTER)
2791 /* Dereference for character pointer results. */
2792 if (sym->attr.pointer || sym->attr.allocatable)
2793 se->expr = build_fold_indirect_ref (var);
2797 se->string_length = len;
2801 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2802 se->expr = build_fold_indirect_ref (var);
2807 /* Follow the function call with the argument post block. */
2809 gfc_add_block_to_block (&se->pre, &post);
2811 gfc_add_block_to_block (&se->post, &post);
2813 return has_alternate_specifier;
2817 /* Generate code to copy a string. */
2820 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2821 tree slength, tree src)
2823 tree tmp, dlen, slen;
2831 stmtblock_t tempblock;
2833 if (slength != NULL_TREE)
2835 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2836 ssc = gfc_to_single_character (slen, src);
2840 slen = build_int_cst (size_type_node, 1);
2844 if (dlength != NULL_TREE)
2846 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2847 dsc = gfc_to_single_character (slen, dest);
2851 dlen = build_int_cst (size_type_node, 1);
2855 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
2856 ssc = gfc_to_single_character (slen, src);
2857 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
2858 dsc = gfc_to_single_character (dlen, dest);
2861 /* Assign directly if the types are compatible. */
2862 if (dsc != NULL_TREE && ssc != NULL_TREE
2863 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
2865 gfc_add_modify_expr (block, dsc, ssc);
2869 /* Do nothing if the destination length is zero. */
2870 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2871 build_int_cst (size_type_node, 0));
2873 /* The following code was previously in _gfortran_copy_string:
2875 // The two strings may overlap so we use memmove.
2877 copy_string (GFC_INTEGER_4 destlen, char * dest,
2878 GFC_INTEGER_4 srclen, const char * src)
2880 if (srclen >= destlen)
2882 // This will truncate if too long.
2883 memmove (dest, src, destlen);
2887 memmove (dest, src, srclen);
2889 memset (&dest[srclen], ' ', destlen - srclen);
2893 We're now doing it here for better optimization, but the logic
2897 dest = fold_convert (pvoid_type_node, dest);
2899 dest = gfc_build_addr_expr (pvoid_type_node, dest);
2902 src = fold_convert (pvoid_type_node, src);
2904 src = gfc_build_addr_expr (pvoid_type_node, src);
2906 /* Truncate string if source is too long. */
2907 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2908 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2909 3, dest, src, dlen);
2911 /* Else copy and pad with spaces. */
2912 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2913 3, dest, src, slen);
2915 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
2916 fold_convert (sizetype, slen));
2917 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2919 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2920 lang_hooks.to_target_charset (' ')),
2921 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2924 gfc_init_block (&tempblock);
2925 gfc_add_expr_to_block (&tempblock, tmp3);
2926 gfc_add_expr_to_block (&tempblock, tmp4);
2927 tmp3 = gfc_finish_block (&tempblock);
2929 /* The whole copy_string function is there. */
2930 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2931 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2932 gfc_add_expr_to_block (block, tmp);
2936 /* Translate a statement function.
2937 The value of a statement function reference is obtained by evaluating the
2938 expression using the values of the actual arguments for the values of the
2939 corresponding dummy arguments. */
2942 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2946 gfc_formal_arglist *fargs;
2947 gfc_actual_arglist *args;
2950 gfc_saved_var *saved_vars;
2956 sym = expr->symtree->n.sym;
2957 args = expr->value.function.actual;
2958 gfc_init_se (&lse, NULL);
2959 gfc_init_se (&rse, NULL);
2962 for (fargs = sym->formal; fargs; fargs = fargs->next)
2964 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2965 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2967 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2969 /* Each dummy shall be specified, explicitly or implicitly, to be
2971 gcc_assert (fargs->sym->attr.dimension == 0);
2974 /* Create a temporary to hold the value. */
2975 type = gfc_typenode_for_spec (&fsym->ts);
2976 temp_vars[n] = gfc_create_var (type, fsym->name);
2978 if (fsym->ts.type == BT_CHARACTER)
2980 /* Copy string arguments. */
2983 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2984 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2986 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2987 tmp = gfc_build_addr_expr (build_pointer_type (type),
2990 gfc_conv_expr (&rse, args->expr);
2991 gfc_conv_string_parameter (&rse);
2992 gfc_add_block_to_block (&se->pre, &lse.pre);
2993 gfc_add_block_to_block (&se->pre, &rse.pre);
2995 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2997 gfc_add_block_to_block (&se->pre, &lse.post);
2998 gfc_add_block_to_block (&se->pre, &rse.post);
3002 /* For everything else, just evaluate the expression. */
3003 gfc_conv_expr (&lse, args->expr);
3005 gfc_add_block_to_block (&se->pre, &lse.pre);
3006 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
3007 gfc_add_block_to_block (&se->pre, &lse.post);
3013 /* Use the temporary variables in place of the real ones. */
3014 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3015 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3017 gfc_conv_expr (se, sym->value);
3019 if (sym->ts.type == BT_CHARACTER)
3021 gfc_conv_const_charlen (sym->ts.cl);
3023 /* Force the expression to the correct length. */
3024 if (!INTEGER_CST_P (se->string_length)
3025 || tree_int_cst_lt (se->string_length,
3026 sym->ts.cl->backend_decl))
3028 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3029 tmp = gfc_create_var (type, sym->name);
3030 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3031 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3032 se->string_length, se->expr);
3035 se->string_length = sym->ts.cl->backend_decl;
3038 /* Restore the original variables. */
3039 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3040 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3041 gfc_free (saved_vars);
3045 /* Translate a function expression. */
3048 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3052 if (expr->value.function.isym)
3054 gfc_conv_intrinsic_function (se, expr);
3058 /* We distinguish statement functions from general functions to improve
3059 runtime performance. */
3060 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3062 gfc_conv_statement_function (se, expr);
3066 /* expr.value.function.esym is the resolved (specific) function symbol for
3067 most functions. However this isn't set for dummy procedures. */
3068 sym = expr->value.function.esym;
3070 sym = expr->symtree->n.sym;
3071 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3076 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3078 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3079 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3081 gfc_conv_tmp_array_ref (se);
3082 gfc_advance_se_ss_chain (se);
3086 /* Build a static initializer. EXPR is the expression for the initial value.
3087 The other parameters describe the variable of the component being
3088 initialized. EXPR may be null. */
3091 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3092 bool array, bool pointer)
3096 if (!(expr || pointer))
3099 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3100 (these are the only two iso_c_binding derived types that can be
3101 used as initialization expressions). If so, we need to modify
3102 the 'expr' to be that for a (void *). */
3103 if (expr != NULL && expr->ts.type == BT_DERIVED
3104 && expr->ts.is_iso_c && expr->ts.derived)
3106 gfc_symbol *derived = expr->ts.derived;
3108 expr = gfc_int_expr (0);
3110 /* The derived symbol has already been converted to a (void *). Use
3112 expr->ts.f90_type = derived->ts.f90_type;
3113 expr->ts.kind = derived->ts.kind;
3118 /* Arrays need special handling. */
3120 return gfc_build_null_descriptor (type);
3122 return gfc_conv_array_initializer (type, expr);
3125 return fold_convert (type, null_pointer_node);
3131 gfc_init_se (&se, NULL);
3132 gfc_conv_structure (&se, expr, 1);
3136 return gfc_conv_string_init (ts->cl->backend_decl,expr);
3139 gfc_init_se (&se, NULL);
3140 gfc_conv_constant (&se, expr);
3147 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3159 gfc_start_block (&block);
3161 /* Initialize the scalarizer. */
3162 gfc_init_loopinfo (&loop);
3164 gfc_init_se (&lse, NULL);
3165 gfc_init_se (&rse, NULL);
3168 rss = gfc_walk_expr (expr);
3169 if (rss == gfc_ss_terminator)
3171 /* The rhs is scalar. Add a ss for the expression. */
3172 rss = gfc_get_ss ();
3173 rss->next = gfc_ss_terminator;
3174 rss->type = GFC_SS_SCALAR;
3178 /* Create a SS for the destination. */
3179 lss = gfc_get_ss ();
3180 lss->type = GFC_SS_COMPONENT;
3182 lss->shape = gfc_get_shape (cm->as->rank);
3183 lss->next = gfc_ss_terminator;
3184 lss->data.info.dimen = cm->as->rank;
3185 lss->data.info.descriptor = dest;
3186 lss->data.info.data = gfc_conv_array_data (dest);
3187 lss->data.info.offset = gfc_conv_array_offset (dest);
3188 for (n = 0; n < cm->as->rank; n++)
3190 lss->data.info.dim[n] = n;
3191 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3192 lss->data.info.stride[n] = gfc_index_one_node;
3194 mpz_init (lss->shape[n]);
3195 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3196 cm->as->lower[n]->value.integer);
3197 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3200 /* Associate the SS with the loop. */
3201 gfc_add_ss_to_loop (&loop, lss);
3202 gfc_add_ss_to_loop (&loop, rss);
3204 /* Calculate the bounds of the scalarization. */
3205 gfc_conv_ss_startstride (&loop);
3207 /* Setup the scalarizing loops. */
3208 gfc_conv_loop_setup (&loop);
3210 /* Setup the gfc_se structures. */
3211 gfc_copy_loopinfo_to_se (&lse, &loop);
3212 gfc_copy_loopinfo_to_se (&rse, &loop);
3215 gfc_mark_ss_chain_used (rss, 1);
3217 gfc_mark_ss_chain_used (lss, 1);
3219 /* Start the scalarized loop body. */
3220 gfc_start_scalarized_body (&loop, &body);
3222 gfc_conv_tmp_array_ref (&lse);
3223 if (cm->ts.type == BT_CHARACTER)
3224 lse.string_length = cm->ts.cl->backend_decl;
3226 gfc_conv_expr (&rse, expr);
3228 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3229 gfc_add_expr_to_block (&body, tmp);
3231 gcc_assert (rse.ss == gfc_ss_terminator);
3233 /* Generate the copying loops. */
3234 gfc_trans_scalarizing_loops (&loop, &body);
3236 /* Wrap the whole thing up. */
3237 gfc_add_block_to_block (&block, &loop.pre);
3238 gfc_add_block_to_block (&block, &loop.post);
3240 for (n = 0; n < cm->as->rank; n++)
3241 mpz_clear (lss->shape[n]);
3242 gfc_free (lss->shape);
3244 gfc_cleanup_loop (&loop);
3246 return gfc_finish_block (&block);
3250 /* Assign a single component of a derived type constructor. */
3253 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3263 gfc_start_block (&block);
3267 gfc_init_se (&se, NULL);
3268 /* Pointer component. */
3271 /* Array pointer. */
3272 if (expr->expr_type == EXPR_NULL)
3273 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3276 rss = gfc_walk_expr (expr);
3277 se.direct_byref = 1;
3279 gfc_conv_expr_descriptor (&se, expr, rss);
3280 gfc_add_block_to_block (&block, &se.pre);
3281 gfc_add_block_to_block (&block, &se.post);
3286 /* Scalar pointers. */
3287 se.want_pointer = 1;
3288 gfc_conv_expr (&se, expr);
3289 gfc_add_block_to_block (&block, &se.pre);
3290 gfc_add_modify_expr (&block, dest,
3291 fold_convert (TREE_TYPE (dest), se.expr));
3292 gfc_add_block_to_block (&block, &se.post);
3295 else if (cm->dimension)
3297 if (cm->allocatable && expr->expr_type == EXPR_NULL)
3298 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3299 else if (cm->allocatable)
3303 gfc_init_se (&se, NULL);
3305 rss = gfc_walk_expr (expr);
3306 se.want_pointer = 0;
3307 gfc_conv_expr_descriptor (&se, expr, rss);
3308 gfc_add_block_to_block (&block, &se.pre);
3310 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3311 gfc_add_modify_expr (&block, dest, tmp);
3313 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3314 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3317 tmp = gfc_duplicate_allocatable (dest, se.expr,
3318 TREE_TYPE(cm->backend_decl),
3321 gfc_add_expr_to_block (&block, tmp);
3323 gfc_add_block_to_block (&block, &se.post);
3324 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3326 /* Shift the lbound and ubound of temporaries to being unity, rather
3327 than zero, based. Calculate the offset for all cases. */
3328 offset = gfc_conv_descriptor_offset (dest);
3329 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3330 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3331 for (n = 0; n < expr->rank; n++)
3333 if (expr->expr_type != EXPR_VARIABLE
3334 && expr->expr_type != EXPR_CONSTANT)
3337 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3338 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3339 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3340 gfc_add_modify_expr (&block, tmp,
3341 fold_build2 (PLUS_EXPR,
3342 gfc_array_index_type,
3343 span, gfc_index_one_node));
3344 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3345 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3347 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3348 gfc_conv_descriptor_lbound (dest,
3350 gfc_conv_descriptor_stride (dest,
3352 gfc_add_modify_expr (&block, tmp2, tmp);
3353 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3354 gfc_add_modify_expr (&block, offset, tmp);
3359 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3360 gfc_add_expr_to_block (&block, tmp);
3363 else if (expr->ts.type == BT_DERIVED)
3365 if (expr->expr_type != EXPR_STRUCTURE)
3367 gfc_init_se (&se, NULL);
3368 gfc_conv_expr (&se, expr);
3369 gfc_add_modify_expr (&block, dest,
3370 fold_convert (TREE_TYPE (dest), se.expr));
3374 /* Nested constructors. */
3375 tmp = gfc_trans_structure_assign (dest, expr);
3376 gfc_add_expr_to_block (&block, tmp);
3381 /* Scalar component. */
3382 gfc_init_se (&se, NULL);
3383 gfc_init_se (&lse, NULL);
3385 gfc_conv_expr (&se, expr);
3386 if (cm->ts.type == BT_CHARACTER)
3387 lse.string_length = cm->ts.cl->backend_decl;
3389 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3390 gfc_add_expr_to_block (&block, tmp);
3392 return gfc_finish_block (&block);
3395 /* Assign a derived type constructor to a variable. */
3398 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3406 gfc_start_block (&block);
3407 cm = expr->ts.derived->components;
3408 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3410 /* Skip absent members in default initializers. */
3414 /* Update the type/kind of the expression if it represents either
3415 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3416 be the first place reached for initializing output variables that
3417 have components of type C_PTR/C_FUNPTR that are initialized. */
3418 if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3419 && c->expr->ts.derived->attr.is_iso_c)
3421 c->expr->expr_type = EXPR_NULL;
3422 c->expr->ts.type = c->expr->ts.derived->ts.type;
3423 c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3424 c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3427 field = cm->backend_decl;
3428 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3429 dest, field, NULL_TREE);
3430 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3431 gfc_add_expr_to_block (&block, tmp);
3433 return gfc_finish_block (&block);
3436 /* Build an expression for a constructor. If init is nonzero then
3437 this is part of a static variable initializer. */
3440 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3447 VEC(constructor_elt,gc) *v = NULL;
3449 gcc_assert (se->ss == NULL);
3450 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3451 type = gfc_typenode_for_spec (&expr->ts);
3455 /* Create a temporary variable and fill it in. */
3456 se->expr = gfc_create_var (type, expr->ts.derived->name);
3457 tmp = gfc_trans_structure_assign (se->expr, expr);
3458 gfc_add_expr_to_block (&se->pre, tmp);
3462 cm = expr->ts.derived->components;
3464 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3466 /* Skip absent members in default initializers and allocatable
3467 components. Although the latter have a default initializer
3468 of EXPR_NULL,... by default, the static nullify is not needed
3469 since this is done every time we come into scope. */
3470 if (!c->expr || cm->allocatable)
3473 val = gfc_conv_initializer (c->expr, &cm->ts,
3474 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3476 /* Append it to the constructor list. */
3477 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3479 se->expr = build_constructor (type, v);
3481 TREE_CONSTANT (se->expr) = 1;
3485 /* Translate a substring expression. */
3488 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3494 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3496 se->expr = gfc_build_string_const (expr->value.character.length,
3497 expr->value.character.string);
3498 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3499 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3502 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3506 /* Entry point for expression translation. Evaluates a scalar quantity.
3507 EXPR is the expression to be translated, and SE is the state structure if
3508 called from within the scalarized. */
3511 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3513 if (se->ss && se->ss->expr == expr
3514 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3516 /* Substitute a scalar expression evaluated outside the scalarization
3518 se->expr = se->ss->data.scalar.expr;
3519 se->string_length = se->ss->string_length;
3520 gfc_advance_se_ss_chain (se);
3524 /* We need to convert the expressions for the iso_c_binding derived types.
3525 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3526 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3527 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3528 updated to be an integer with a kind equal to the size of a (void *). */
3529 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3530 && expr->ts.derived->attr.is_iso_c)
3532 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3533 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3535 /* Set expr_type to EXPR_NULL, which will result in
3536 null_pointer_node being used below. */
3537 expr->expr_type = EXPR_NULL;
3541 /* Update the type/kind of the expression to be what the new
3542 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3543 expr->ts.type = expr->ts.derived->ts.type;
3544 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3545 expr->ts.kind = expr->ts.derived->ts.kind;
3549 switch (expr->expr_type)
3552 gfc_conv_expr_op (se, expr);
3556 gfc_conv_function_expr (se, expr);
3560 gfc_conv_constant (se, expr);
3564 gfc_conv_variable (se, expr);
3568 se->expr = null_pointer_node;
3571 case EXPR_SUBSTRING:
3572 gfc_conv_substring_expr (se, expr);
3575 case EXPR_STRUCTURE:
3576 gfc_conv_structure (se, expr, 0);
3580 gfc_conv_array_constructor_expr (se, expr);
3589 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3590 of an assignment. */
3592 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3594 gfc_conv_expr (se, expr);
3595 /* All numeric lvalues should have empty post chains. If not we need to
3596 figure out a way of rewriting an lvalue so that it has no post chain. */
3597 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3600 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3601 numeric expressions. Used for scalar values where inserting cleanup code
3604 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3608 gcc_assert (expr->ts.type != BT_CHARACTER);
3609 gfc_conv_expr (se, expr);
3612 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3613 gfc_add_modify_expr (&se->pre, val, se->expr);
3615 gfc_add_block_to_block (&se->pre, &se->post);
3619 /* Helper to translate an expression and convert it to a particular type. */
3621 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3623 gfc_conv_expr_val (se, expr);
3624 se->expr = convert (type, se->expr);
3628 /* Converts an expression so that it can be passed by reference. Scalar
3632 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3636 if (se->ss && se->ss->expr == expr
3637 && se->ss->type == GFC_SS_REFERENCE)
3639 se->expr = se->ss->data.scalar.expr;
3640 se->string_length = se->ss->string_length;
3641 gfc_advance_se_ss_chain (se);
3645 if (expr->ts.type == BT_CHARACTER)
3647 gfc_conv_expr (se, expr);
3648 gfc_conv_string_parameter (se);
3652 if (expr->expr_type == EXPR_VARIABLE)
3654 se->want_pointer = 1;
3655 gfc_conv_expr (se, expr);
3658 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3659 gfc_add_modify_expr (&se->pre, var, se->expr);
3660 gfc_add_block_to_block (&se->pre, &se->post);
3666 if (expr->expr_type == EXPR_FUNCTION
3667 && expr->symtree->n.sym->attr.pointer
3668 && !expr->symtree->n.sym->attr.dimension)
3670 se->want_pointer = 1;
3671 gfc_conv_expr (se, expr);
3672 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3673 gfc_add_modify_expr (&se->pre, var, se->expr);
3679 gfc_conv_expr (se, expr);
3681 /* Create a temporary var to hold the value. */
3682 if (TREE_CONSTANT (se->expr))
3684 tree tmp = se->expr;
3685 STRIP_TYPE_NOPS (tmp);
3686 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3687 DECL_INITIAL (var) = tmp;
3688 TREE_STATIC (var) = 1;
3693 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3694 gfc_add_modify_expr (&se->pre, var, se->expr);
3696 gfc_add_block_to_block (&se->pre, &se->post);
3698 /* Take the address of that value. */
3699 se->expr = build_fold_addr_expr (var);
3704 gfc_trans_pointer_assign (gfc_code * code)
3706 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3710 /* Generate code for a pointer assignment. */
3713 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3725 gfc_start_block (&block);
3727 gfc_init_se (&lse, NULL);
3729 lss = gfc_walk_expr (expr1);
3730 rss = gfc_walk_expr (expr2);
3731 if (lss == gfc_ss_terminator)
3733 /* Scalar pointers. */
3734 lse.want_pointer = 1;
3735 gfc_conv_expr (&lse, expr1);
3736 gcc_assert (rss == gfc_ss_terminator);
3737 gfc_init_se (&rse, NULL);
3738 rse.want_pointer = 1;
3739 gfc_conv_expr (&rse, expr2);
3740 gfc_add_block_to_block (&block, &lse.pre);
3741 gfc_add_block_to_block (&block, &rse.pre);
3742 gfc_add_modify_expr (&block, lse.expr,
3743 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3744 gfc_add_block_to_block (&block, &rse.post);
3745 gfc_add_block_to_block (&block, &lse.post);
3749 /* Array pointer. */
3750 gfc_conv_expr_descriptor (&lse, expr1, lss);
3751 switch (expr2->expr_type)
3754 /* Just set the data pointer to null. */
3755 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3759 /* Assign directly to the pointer's descriptor. */
3760 lse.direct_byref = 1;
3761 gfc_conv_expr_descriptor (&lse, expr2, rss);
3763 /* If this is a subreference array pointer assignment, use the rhs
3764 descriptor element size for the lhs span. */
3765 if (expr1->symtree->n.sym->attr.subref_array_pointer)
3767 decl = expr1->symtree->n.sym->backend_decl;
3768 gfc_init_se (&rse, NULL);
3769 rse.descriptor_only = 1;
3770 gfc_conv_expr (&rse, expr2);
3771 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
3772 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
3773 if (!INTEGER_CST_P (tmp))
3774 gfc_add_block_to_block (&lse.post, &rse.pre);
3775 gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
3781 /* Assign to a temporary descriptor and then copy that
3782 temporary to the pointer. */
3784 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3787 lse.direct_byref = 1;
3788 gfc_conv_expr_descriptor (&lse, expr2, rss);
3789 gfc_add_modify_expr (&lse.pre, desc, tmp);
3792 gfc_add_block_to_block (&block, &lse.pre);
3793 gfc_add_block_to_block (&block, &lse.post);
3795 return gfc_finish_block (&block);
3799 /* Makes sure se is suitable for passing as a function string parameter. */
3800 /* TODO: Need to check all callers fo this function. It may be abused. */
3803 gfc_conv_string_parameter (gfc_se * se)
3807 if (TREE_CODE (se->expr) == STRING_CST)
3809 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3813 type = TREE_TYPE (se->expr);
3814 if (TYPE_STRING_FLAG (type))
3816 if (TREE_CODE (se->expr) != INDIRECT_REF)
3817 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3820 type = gfc_get_character_type_len (gfc_default_character_kind,
3822 type = build_pointer_type (type);
3823 se->expr = gfc_build_addr_expr (type, se->expr);
3827 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3828 gcc_assert (se->string_length
3829 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3833 /* Generate code for assignment of scalar variables. Includes character
3834 strings and derived types with allocatable components. */
3837 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3838 bool l_is_temp, bool r_is_var)
3844 gfc_init_block (&block);
3846 if (ts.type == BT_CHARACTER)
3851 if (lse->string_length != NULL_TREE)
3853 gfc_conv_string_parameter (lse);
3854 gfc_add_block_to_block (&block, &lse->pre);
3855 llen = lse->string_length;
3858 if (rse->string_length != NULL_TREE)
3860 gcc_assert (rse->string_length != NULL_TREE);
3861 gfc_conv_string_parameter (rse);
3862 gfc_add_block_to_block (&block, &rse->pre);
3863 rlen = rse->string_length;
3866 gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr);
3868 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3872 /* Are the rhs and the lhs the same? */
3875 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3876 build_fold_addr_expr (lse->expr),
3877 build_fold_addr_expr (rse->expr));
3878 cond = gfc_evaluate_now (cond, &lse->pre);
3881 /* Deallocate the lhs allocated components as long as it is not
3882 the same as the rhs. This must be done following the assignment
3883 to prevent deallocating data that could be used in the rhs
3887 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
3888 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
3890 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3891 gfc_add_expr_to_block (&lse->post, tmp);
3894 gfc_add_block_to_block (&block, &rse->pre);
3895 gfc_add_block_to_block (&block, &lse->pre);
3897 gfc_add_modify_expr (&block, lse->expr,
3898 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3900 /* Do a deep copy if the rhs is a variable, if it is not the
3904 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3905 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3906 gfc_add_expr_to_block (&block, tmp);
3911 gfc_add_block_to_block (&block, &lse->pre);
3912 gfc_add_block_to_block (&block, &rse->pre);
3914 gfc_add_modify_expr (&block, lse->expr,
3915 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3918 gfc_add_block_to_block (&block, &lse->post);
3919 gfc_add_block_to_block (&block, &rse->post);
3921 return gfc_finish_block (&block);
3925 /* Try to translate array(:) = func (...), where func is a transformational
3926 array function, without using a temporary. Returns NULL is this isn't the
3930 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3935 bool seen_array_ref;
3937 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3938 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3941 /* Elemental functions don't need a temporary anyway. */
3942 if (expr2->value.function.esym != NULL
3943 && expr2->value.function.esym->attr.elemental)
3946 /* Fail if EXPR1 can't be expressed as a descriptor. */
3947 if (gfc_ref_needs_temporary_p (expr1->ref))
3950 /* Functions returning pointers need temporaries. */
3951 if (expr2->symtree->n.sym->attr.pointer
3952 || expr2->symtree->n.sym->attr.allocatable)
3955 /* Character array functions need temporaries unless the
3956 character lengths are the same. */
3957 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3959 if (expr1->ts.cl->length == NULL
3960 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3963 if (expr2->ts.cl->length == NULL
3964 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3967 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3968 expr2->ts.cl->length->value.integer) != 0)
3972 /* Check that no LHS component references appear during an array
3973 reference. This is needed because we do not have the means to
3974 span any arbitrary stride with an array descriptor. This check
3975 is not needed for the rhs because the function result has to be
3977 seen_array_ref = false;
3978 for (ref = expr1->ref; ref; ref = ref->next)
3980 if (ref->type == REF_ARRAY)
3981 seen_array_ref= true;
3982 else if (ref->type == REF_COMPONENT && seen_array_ref)
3986 /* Check for a dependency. */
3987 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3988 expr2->value.function.esym,
3989 expr2->value.function.actual))
3992 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3994 gcc_assert (expr2->value.function.isym
3995 || (gfc_return_by_reference (expr2->value.function.esym)
3996 && expr2->value.function.esym->result->attr.dimension));
3998 ss = gfc_walk_expr (expr1);
3999 gcc_assert (ss != gfc_ss_terminator);
4000 gfc_init_se (&se, NULL);
4001 gfc_start_block (&se.pre);
4002 se.want_pointer = 1;
4004 gfc_conv_array_parameter (&se, expr1, ss, 0);
4006 se.direct_byref = 1;
4007 se.ss = gfc_walk_expr (expr2);
4008 gcc_assert (se.ss != gfc_ss_terminator);
4009 gfc_conv_function_expr (&se, expr2);
4010 gfc_add_block_to_block (&se.pre, &se.post);
4012 return gfc_finish_block (&se.pre);
4015 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4018 is_zero_initializer_p (gfc_expr * expr)
4020 if (expr->expr_type != EXPR_CONSTANT)
4023 /* We ignore constants with prescribed memory representations for now. */
4024 if (expr->representation.string)
4027 switch (expr->ts.type)
4030 return mpz_cmp_si (expr->value.integer, 0) == 0;
4033 return mpfr_zero_p (expr->value.real)
4034 && MPFR_SIGN (expr->value.real) >= 0;
4037 return expr->value.logical == 0;
4040 return mpfr_zero_p (expr->value.complex.r)
4041 && MPFR_SIGN (expr->value.complex.r) >= 0
4042 && mpfr_zero_p (expr->value.complex.i)
4043 && MPFR_SIGN (expr->value.complex.i) >= 0;
4051 /* Try to efficiently translate array(:) = 0. Return NULL if this
4055 gfc_trans_zero_assign (gfc_expr * expr)
4057 tree dest, len, type;
4061 sym = expr->symtree->n.sym;
4062 dest = gfc_get_symbol_decl (sym);
4064 type = TREE_TYPE (dest);
4065 if (POINTER_TYPE_P (type))
4066 type = TREE_TYPE (type);
4067 if (!GFC_ARRAY_TYPE_P (type))
4070 /* Determine the length of the array. */
4071 len = GFC_TYPE_ARRAY_SIZE (type);
4072 if (!len || TREE_CODE (len) != INTEGER_CST)
4075 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4076 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4077 fold_convert (gfc_array_index_type, tmp));
4079 /* Convert arguments to the correct types. */
4080 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4081 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4083 dest = fold_convert (pvoid_type_node, dest);
4084 len = fold_convert (size_type_node, len);
4086 /* Construct call to __builtin_memset. */
4087 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4088 3, dest, integer_zero_node, len);
4089 return fold_convert (void_type_node, tmp);
4093 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4094 that constructs the call to __builtin_memcpy. */
4097 gfc_build_memcpy_call (tree dst, tree src, tree len)
4101 /* Convert arguments to the correct types. */
4102 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4103 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4105 dst = fold_convert (pvoid_type_node, dst);
4107 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4108 src = gfc_build_addr_expr (pvoid_type_node, src);
4110 src = fold_convert (pvoid_type_node, src);
4112 len = fold_convert (size_type_node, len);
4114 /* Construct call to __builtin_memcpy. */
4115 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4116 return fold_convert (void_type_node, tmp);
4120 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4121 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4122 source/rhs, both are gfc_full_array_ref_p which have been checked for
4126 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4128 tree dst, dlen, dtype;
4129 tree src, slen, stype;
4132 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4133 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4135 dtype = TREE_TYPE (dst);
4136 if (POINTER_TYPE_P (dtype))
4137 dtype = TREE_TYPE (dtype);
4138 stype = TREE_TYPE (src);
4139 if (POINTER_TYPE_P (stype))
4140 stype = TREE_TYPE (stype);
4142 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4145 /* Determine the lengths of the arrays. */
4146 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4147 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4149 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4150 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4151 fold_convert (gfc_array_index_type, tmp));
4153 slen = GFC_TYPE_ARRAY_SIZE (stype);
4154 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4156 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4157 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4158 fold_convert (gfc_array_index_type, tmp));
4160 /* Sanity check that they are the same. This should always be
4161 the case, as we should already have checked for conformance. */
4162 if (!tree_int_cst_equal (slen, dlen))
4165 return gfc_build_memcpy_call (dst, src, dlen);
4169 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4170 this can't be done. EXPR1 is the destination/lhs for which
4171 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4174 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4176 unsigned HOST_WIDE_INT nelem;
4182 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4186 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4187 dtype = TREE_TYPE (dst);
4188 if (POINTER_TYPE_P (dtype))
4189 dtype = TREE_TYPE (dtype);
4190 if (!GFC_ARRAY_TYPE_P (dtype))
4193 /* Determine the lengths of the array. */
4194 len = GFC_TYPE_ARRAY_SIZE (dtype);
4195 if (!len || TREE_CODE (len) != INTEGER_CST)
4198 /* Confirm that the constructor is the same size. */
4199 if (compare_tree_int (len, nelem) != 0)
4202 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4203 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4204 fold_convert (gfc_array_index_type, tmp));
4206 stype = gfc_typenode_for_spec (&expr2->ts);
4207 src = gfc_build_constant_array_constructor (expr2, stype);
4209 stype = TREE_TYPE (src);
4210 if (POINTER_TYPE_P (stype))
4211 stype = TREE_TYPE (stype);
4213 return gfc_build_memcpy_call (dst, src, len);
4217 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4218 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4221 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4226 gfc_ss *lss_section;
4234 /* Assignment of the form lhs = rhs. */
4235 gfc_start_block (&block);
4237 gfc_init_se (&lse, NULL);
4238 gfc_init_se (&rse, NULL);
4241 lss = gfc_walk_expr (expr1);
4243 if (lss != gfc_ss_terminator)
4245 /* The assignment needs scalarization. */
4248 /* Find a non-scalar SS from the lhs. */
4249 while (lss_section != gfc_ss_terminator
4250 && lss_section->type != GFC_SS_SECTION)
4251 lss_section = lss_section->next;
4253 gcc_assert (lss_section != gfc_ss_terminator);
4255 /* Initialize the scalarizer. */
4256 gfc_init_loopinfo (&loop);
4259 rss = gfc_walk_expr (expr2);
4260 if (rss == gfc_ss_terminator)
4262 /* The rhs is scalar. Add a ss for the expression. */
4263 rss = gfc_get_ss ();
4264 rss->next = gfc_ss_terminator;
4265 rss->type = GFC_SS_SCALAR;
4268 /* Associate the SS with the loop. */
4269 gfc_add_ss_to_loop (&loop, lss);
4270 gfc_add_ss_to_loop (&loop, rss);
4272 /* Calculate the bounds of the scalarization. */
4273 gfc_conv_ss_startstride (&loop);
4274 /* Resolve any data dependencies in the statement. */
4275 gfc_conv_resolve_dependencies (&loop, lss, rss);
4276 /* Setup the scalarizing loops. */
4277 gfc_conv_loop_setup (&loop);
4279 /* Setup the gfc_se structures. */
4280 gfc_copy_loopinfo_to_se (&lse, &loop);
4281 gfc_copy_loopinfo_to_se (&rse, &loop);
4284 gfc_mark_ss_chain_used (rss, 1);
4285 if (loop.temp_ss == NULL)
4288 gfc_mark_ss_chain_used (lss, 1);
4292 lse.ss = loop.temp_ss;
4293 gfc_mark_ss_chain_used (lss, 3);
4294 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4297 /* Start the scalarized loop body. */
4298 gfc_start_scalarized_body (&loop, &body);
4301 gfc_init_block (&body);
4303 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4305 /* Translate the expression. */
4306 gfc_conv_expr (&rse, expr2);
4310 gfc_conv_tmp_array_ref (&lse);
4311 gfc_advance_se_ss_chain (&lse);
4314 gfc_conv_expr (&lse, expr1);
4316 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4317 l_is_temp || init_flag,
4318 expr2->expr_type == EXPR_VARIABLE);
4319 gfc_add_expr_to_block (&body, tmp);
4321 if (lss == gfc_ss_terminator)
4323 /* Use the scalar assignment as is. */
4324 gfc_add_block_to_block (&block, &body);
4328 gcc_assert (lse.ss == gfc_ss_terminator
4329 && rse.ss == gfc_ss_terminator);
4333 gfc_trans_scalarized_loop_boundary (&loop, &body);
4335 /* We need to copy the temporary to the actual lhs. */
4336 gfc_init_se (&lse, NULL);
4337 gfc_init_se (&rse, NULL);
4338 gfc_copy_loopinfo_to_se (&lse, &loop);
4339 gfc_copy_loopinfo_to_se (&rse, &loop);
4341 rse.ss = loop.temp_ss;
4344 gfc_conv_tmp_array_ref (&rse);
4345 gfc_advance_se_ss_chain (&rse);
4346 gfc_conv_expr (&lse, expr1);
4348 gcc_assert (lse.ss == gfc_ss_terminator
4349 && rse.ss == gfc_ss_terminator);
4351 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4353 gfc_add_expr_to_block (&body, tmp);
4356 /* Generate the copying loops. */
4357 gfc_trans_scalarizing_loops (&loop, &body);
4359 /* Wrap the whole thing up. */
4360 gfc_add_block_to_block (&block, &loop.pre);
4361 gfc_add_block_to_block (&block, &loop.post);
4363 gfc_cleanup_loop (&loop);
4366 return gfc_finish_block (&block);
4370 /* Check whether EXPR is a copyable array. */
4373 copyable_array_p (gfc_expr * expr)
4375 if (expr->expr_type != EXPR_VARIABLE)
4378 /* First check it's an array. */
4379 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4382 if (!gfc_full_array_ref_p (expr->ref))
4385 /* Next check that it's of a simple enough type. */
4386 switch (expr->ts.type)
4398 return !expr->ts.derived->attr.alloc_comp;
4407 /* Translate an assignment. */
4410 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4414 /* Special case a single function returning an array. */
4415 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4417 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4422 /* Special case assigning an array to zero. */
4423 if (copyable_array_p (expr1)
4424 && is_zero_initializer_p (expr2))
4426 tmp = gfc_trans_zero_assign (expr1);
4431 /* Special case copying one array to another. */
4432 if (copyable_array_p (expr1)
4433 && copyable_array_p (expr2)
4434 && gfc_compare_types (&expr1->ts, &expr2->ts)
4435 && !gfc_check_dependency (expr1, expr2, 0))
4437 tmp = gfc_trans_array_copy (expr1, expr2);
4442 /* Special case initializing an array from a constant array constructor. */
4443 if (copyable_array_p (expr1)
4444 && expr2->expr_type == EXPR_ARRAY
4445 && gfc_compare_types (&expr1->ts, &expr2->ts))
4447 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4452 /* Fallback to the scalarizer to generate explicit loops. */
4453 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4457 gfc_trans_init_assign (gfc_code * code)
4459 return gfc_trans_assignment (code->expr, code->expr2, true);
4463 gfc_trans_assign (gfc_code * code)
4465 return gfc_trans_assignment (code->expr, code->expr2, false);