1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
34 #include "tree-gimple.h"
35 #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 int 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 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)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
156 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
157 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
159 tmp = gfc_evaluate_now (tmp, &se->pre);
161 if (ts.type == BT_CHARACTER)
163 tmp = build_int_cst (gfc_charlen_type_node, 0);
164 tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
165 se->string_length, tmp);
166 tmp = gfc_evaluate_now (tmp, &se->pre);
167 se->string_length = tmp;
173 /* Get the character length of an expression, looking through gfc_refs
177 gfc_get_expr_charlen (gfc_expr *e)
182 gcc_assert (e->expr_type == EXPR_VARIABLE
183 && e->ts.type == BT_CHARACTER);
185 length = NULL; /* To silence compiler warning. */
187 /* First candidate: if the variable is of type CHARACTER, the
188 expression's length could be the length of the character
190 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
191 length = e->symtree->n.sym->ts.cl->backend_decl;
193 /* Look through the reference chain for component references. */
194 for (r = e->ref; r; r = r->next)
199 if (r->u.c.component->ts.type == BT_CHARACTER)
200 length = r->u.c.component->ts.cl->backend_decl;
208 /* We should never got substring references here. These will be
209 broken down by the scalarizer. */
214 gcc_assert (length != NULL);
220 /* Generate code to initialize a string length variable. Returns the
224 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
229 gfc_init_se (&se, NULL);
230 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
231 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
232 build_int_cst (gfc_charlen_type_node, 0));
233 gfc_add_block_to_block (pblock, &se.pre);
235 tmp = cl->backend_decl;
236 gfc_add_modify_expr (pblock, tmp, se.expr);
241 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
242 const char *name, locus *where)
252 type = gfc_get_character_type (kind, ref->u.ss.length);
253 type = build_pointer_type (type);
256 gfc_init_se (&start, se);
257 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
258 gfc_add_block_to_block (&se->pre, &start.pre);
260 if (integer_onep (start.expr))
261 gfc_conv_string_parameter (se);
264 /* Avoid multiple evaluation of substring start. */
265 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
266 start.expr = gfc_evaluate_now (start.expr, &se->pre);
268 /* Change the start of the string. */
269 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
272 tmp = build_fold_indirect_ref (se->expr);
273 tmp = gfc_build_array_ref (tmp, start.expr);
274 se->expr = gfc_build_addr_expr (type, tmp);
277 /* Length = end + 1 - start. */
278 gfc_init_se (&end, se);
279 if (ref->u.ss.end == NULL)
280 end.expr = se->string_length;
283 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
284 gfc_add_block_to_block (&se->pre, &end.pre);
286 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
287 end.expr = gfc_evaluate_now (end.expr, &se->pre);
289 if (flag_bounds_check)
291 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
292 start.expr, end.expr);
294 /* Check lower bound. */
295 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
296 build_int_cst (gfc_charlen_type_node, 1));
297 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
300 asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
301 "is less than one", name);
303 asprintf (&msg, "Substring out of bounds: lower bound "
305 gfc_trans_runtime_check (fault, msg, &se->pre, where);
308 /* Check upper bound. */
309 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
311 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
314 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
315 "exceeds string length", name);
317 asprintf (&msg, "Substring out of bounds: upper bound "
318 "exceeds string length");
319 gfc_trans_runtime_check (fault, msg, &se->pre, where);
323 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
324 build_int_cst (gfc_charlen_type_node, 1),
326 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
327 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
328 build_int_cst (gfc_charlen_type_node, 0));
329 se->string_length = tmp;
333 /* Convert a derived type component reference. */
336 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
343 c = ref->u.c.component;
345 gcc_assert (c->backend_decl);
347 field = c->backend_decl;
348 gcc_assert (TREE_CODE (field) == FIELD_DECL);
350 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
354 if (c->ts.type == BT_CHARACTER)
356 tmp = c->ts.cl->backend_decl;
357 /* Components must always be constant length. */
358 gcc_assert (tmp && INTEGER_CST_P (tmp));
359 se->string_length = tmp;
362 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
363 se->expr = build_fold_indirect_ref (se->expr);
367 /* Return the contents of a variable. Also handles reference/pointer
368 variables (all Fortran pointer references are implicit). */
371 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
378 bool alternate_entry;
381 sym = expr->symtree->n.sym;
384 /* Check that something hasn't gone horribly wrong. */
385 gcc_assert (se->ss != gfc_ss_terminator);
386 gcc_assert (se->ss->expr == expr);
388 /* A scalarized term. We already know the descriptor. */
389 se->expr = se->ss->data.info.descriptor;
390 se->string_length = se->ss->string_length;
391 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
392 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
397 tree se_expr = NULL_TREE;
399 se->expr = gfc_get_symbol_decl (sym);
401 /* Deal with references to a parent results or entries by storing
402 the current_function_decl and moving to the parent_decl. */
403 return_value = sym->attr.function && sym->result == sym;
404 alternate_entry = sym->attr.function && sym->attr.entry
405 && sym->result == sym;
406 entry_master = sym->attr.result
407 && sym->ns->proc_name->attr.entry_master
408 && !gfc_return_by_reference (sym->ns->proc_name);
409 parent_decl = DECL_CONTEXT (current_function_decl);
411 if ((se->expr == parent_decl && return_value)
412 || (sym->ns && sym->ns->proc_name
414 && sym->ns->proc_name->backend_decl == parent_decl
415 && (alternate_entry || entry_master)))
420 /* Special case for assigning the return value of a function.
421 Self recursive functions must have an explicit return value. */
422 if (return_value && (se->expr == current_function_decl || parent_flag))
423 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
425 /* Similarly for alternate entry points. */
426 else if (alternate_entry
427 && (sym->ns->proc_name->backend_decl == current_function_decl
430 gfc_entry_list *el = NULL;
432 for (el = sym->ns->entries; el; el = el->next)
435 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
440 else if (entry_master
441 && (sym->ns->proc_name->backend_decl == current_function_decl
443 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
448 /* Procedure actual arguments. */
449 else if (sym->attr.flavor == FL_PROCEDURE
450 && se->expr != current_function_decl)
452 gcc_assert (se->want_pointer);
453 if (!sym->attr.dummy)
455 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
456 se->expr = build_fold_addr_expr (se->expr);
462 /* Dereference the expression, where needed. Since characters
463 are entirely different from other types, they are treated
465 if (sym->ts.type == BT_CHARACTER)
467 /* Dereference character pointer dummy arguments
469 if ((sym->attr.pointer || sym->attr.allocatable)
471 || sym->attr.function
472 || sym->attr.result))
473 se->expr = build_fold_indirect_ref (se->expr);
475 /* A character with VALUE attribute needs an address
478 se->expr = build_fold_addr_expr (se->expr);
481 else if (!sym->attr.value)
483 /* Dereference non-character scalar dummy arguments. */
484 if (sym->attr.dummy && !sym->attr.dimension)
485 se->expr = build_fold_indirect_ref (se->expr);
487 /* Dereference scalar hidden result. */
488 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
489 && (sym->attr.function || sym->attr.result)
490 && !sym->attr.dimension && !sym->attr.pointer)
491 se->expr = build_fold_indirect_ref (se->expr);
493 /* Dereference non-character pointer variables.
494 These must be dummies, results, or scalars. */
495 if ((sym->attr.pointer || sym->attr.allocatable)
497 || sym->attr.function
499 || !sym->attr.dimension))
500 se->expr = build_fold_indirect_ref (se->expr);
506 /* For character variables, also get the length. */
507 if (sym->ts.type == BT_CHARACTER)
509 /* If the character length of an entry isn't set, get the length from
510 the master function instead. */
511 if (sym->attr.entry && !sym->ts.cl->backend_decl)
512 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
514 se->string_length = sym->ts.cl->backend_decl;
515 gcc_assert (se->string_length);
523 /* Return the descriptor if that's what we want and this is an array
524 section reference. */
525 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
527 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
528 /* Return the descriptor for array pointers and allocations. */
530 && ref->next == NULL && (se->descriptor_only))
533 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
534 /* Return a pointer to an element. */
538 gfc_conv_component_ref (se, ref);
542 gfc_conv_substring (se, ref, expr->ts.kind,
543 expr->symtree->name, &expr->where);
552 /* Pointer assignment, allocation or pass by reference. Arrays are handled
554 if (se->want_pointer)
556 if (expr->ts.type == BT_CHARACTER)
557 gfc_conv_string_parameter (se);
559 se->expr = build_fold_addr_expr (se->expr);
564 /* Unary ops are easy... Or they would be if ! was a valid op. */
567 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
572 gcc_assert (expr->ts.type != BT_CHARACTER);
573 /* Initialize the operand. */
574 gfc_init_se (&operand, se);
575 gfc_conv_expr_val (&operand, expr->value.op.op1);
576 gfc_add_block_to_block (&se->pre, &operand.pre);
578 type = gfc_typenode_for_spec (&expr->ts);
580 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
581 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
582 All other unary operators have an equivalent GIMPLE unary operator. */
583 if (code == TRUTH_NOT_EXPR)
584 se->expr = build2 (EQ_EXPR, type, operand.expr,
585 build_int_cst (type, 0));
587 se->expr = build1 (code, type, operand.expr);
591 /* Expand power operator to optimal multiplications when a value is raised
592 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
593 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
594 Programming", 3rd Edition, 1998. */
596 /* This code is mostly duplicated from expand_powi in the backend.
597 We establish the "optimal power tree" lookup table with the defined size.
598 The items in the table are the exponents used to calculate the index
599 exponents. Any integer n less than the value can get an "addition chain",
600 with the first node being one. */
601 #define POWI_TABLE_SIZE 256
603 /* The table is from builtins.c. */
604 static const unsigned char powi_table[POWI_TABLE_SIZE] =
606 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
607 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
608 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
609 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
610 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
611 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
612 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
613 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
614 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
615 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
616 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
617 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
618 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
619 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
620 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
621 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
622 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
623 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
624 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
625 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
626 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
627 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
628 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
629 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
630 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
631 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
632 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
633 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
634 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
635 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
636 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
637 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
640 /* If n is larger than lookup table's max index, we use the "window
642 #define POWI_WINDOW_SIZE 3
644 /* Recursive function to expand the power operator. The temporary
645 values are put in tmpvar. The function returns tmpvar[1] ** n. */
647 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
654 if (n < POWI_TABLE_SIZE)
659 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
660 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
664 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
665 op0 = gfc_conv_powi (se, n - digit, tmpvar);
666 op1 = gfc_conv_powi (se, digit, tmpvar);
670 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
674 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
675 tmp = gfc_evaluate_now (tmp, &se->pre);
677 if (n < POWI_TABLE_SIZE)
684 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
685 return 1. Else return 0 and a call to runtime library functions
686 will have to be built. */
688 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
693 tree vartmp[POWI_TABLE_SIZE];
695 unsigned HOST_WIDE_INT n;
698 /* If exponent is too large, we won't expand it anyway, so don't bother
699 with large integer values. */
700 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
703 m = double_int_to_shwi (TREE_INT_CST (rhs));
704 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
705 of the asymmetric range of the integer type. */
706 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
708 type = TREE_TYPE (lhs);
709 sgn = tree_int_cst_sgn (rhs);
711 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
712 || optimize_size) && (m > 2 || m < -1))
718 se->expr = gfc_build_const (type, integer_one_node);
722 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
723 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
725 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
726 build_int_cst (TREE_TYPE (lhs), -1));
727 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
728 build_int_cst (TREE_TYPE (lhs), 1));
731 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
734 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
735 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
736 build_int_cst (type, 0));
740 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
741 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
742 build_int_cst (type, 0));
743 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
747 memset (vartmp, 0, sizeof (vartmp));
751 tmp = gfc_build_const (type, integer_one_node);
752 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
755 se->expr = gfc_conv_powi (se, n, vartmp);
761 /* Power op (**). Constant integer exponent has special handling. */
764 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
766 tree gfc_int4_type_node;
773 gfc_init_se (&lse, se);
774 gfc_conv_expr_val (&lse, expr->value.op.op1);
775 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
776 gfc_add_block_to_block (&se->pre, &lse.pre);
778 gfc_init_se (&rse, se);
779 gfc_conv_expr_val (&rse, expr->value.op.op2);
780 gfc_add_block_to_block (&se->pre, &rse.pre);
782 if (expr->value.op.op2->ts.type == BT_INTEGER
783 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
784 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
787 gfc_int4_type_node = gfc_get_int_type (4);
789 kind = expr->value.op.op1->ts.kind;
790 switch (expr->value.op.op2->ts.type)
793 ikind = expr->value.op.op2->ts.kind;
798 rse.expr = convert (gfc_int4_type_node, rse.expr);
820 if (expr->value.op.op1->ts.type == BT_INTEGER)
821 lse.expr = convert (gfc_int4_type_node, lse.expr);
846 switch (expr->value.op.op1->ts.type)
849 if (kind == 3) /* Case 16 was not handled properly above. */
851 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
855 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
859 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
871 fndecl = built_in_decls[BUILT_IN_POWF];
874 fndecl = built_in_decls[BUILT_IN_POW];
878 fndecl = built_in_decls[BUILT_IN_POWL];
889 fndecl = gfor_fndecl_math_cpowf;
892 fndecl = gfor_fndecl_math_cpow;
895 fndecl = gfor_fndecl_math_cpowl10;
898 fndecl = gfor_fndecl_math_cpowl16;
910 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
914 /* Generate code to allocate a string temporary. */
917 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
922 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
924 if (gfc_can_put_var_on_stack (len))
926 /* Create a temporary variable to hold the result. */
927 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
928 build_int_cst (gfc_charlen_type_node, 1));
929 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
930 tmp = build_array_type (gfc_character1_type_node, tmp);
931 var = gfc_create_var (tmp, "str");
932 var = gfc_build_addr_expr (type, var);
936 /* Allocate a temporary to hold the result. */
937 var = gfc_create_var (type, "pstr");
938 tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, len);
939 tmp = convert (type, tmp);
940 gfc_add_modify_expr (&se->pre, var, tmp);
942 /* Free the temporary afterwards. */
943 tmp = convert (pvoid_type_node, var);
944 tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
945 gfc_add_expr_to_block (&se->post, tmp);
952 /* Handle a string concatenation operation. A temporary will be allocated to
956 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
965 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
966 && expr->value.op.op2->ts.type == BT_CHARACTER);
968 gfc_init_se (&lse, se);
969 gfc_conv_expr (&lse, expr->value.op.op1);
970 gfc_conv_string_parameter (&lse);
971 gfc_init_se (&rse, se);
972 gfc_conv_expr (&rse, expr->value.op.op2);
973 gfc_conv_string_parameter (&rse);
975 gfc_add_block_to_block (&se->pre, &lse.pre);
976 gfc_add_block_to_block (&se->pre, &rse.pre);
978 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
979 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
980 if (len == NULL_TREE)
982 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
983 lse.string_length, rse.string_length);
986 type = build_pointer_type (type);
988 var = gfc_conv_string_tmp (se, type, len);
990 /* Do the actual concatenation. */
991 tmp = build_call_expr (gfor_fndecl_concat_string, 6,
993 lse.string_length, lse.expr,
994 rse.string_length, rse.expr);
995 gfc_add_expr_to_block (&se->pre, tmp);
997 /* Add the cleanup for the operands. */
998 gfc_add_block_to_block (&se->pre, &rse.post);
999 gfc_add_block_to_block (&se->pre, &lse.post);
1002 se->string_length = len;
1005 /* Translates an op expression. Common (binary) cases are handled by this
1006 function, others are passed on. Recursion is used in either case.
1007 We use the fact that (op1.ts == op2.ts) (except for the power
1009 Operators need no special handling for scalarized expressions as long as
1010 they call gfc_conv_simple_val to get their operands.
1011 Character strings get special handling. */
1014 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1016 enum tree_code code;
1026 switch (expr->value.op.operator)
1028 case INTRINSIC_UPLUS:
1029 case INTRINSIC_PARENTHESES:
1030 gfc_conv_expr (se, expr->value.op.op1);
1033 case INTRINSIC_UMINUS:
1034 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1038 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1041 case INTRINSIC_PLUS:
1045 case INTRINSIC_MINUS:
1049 case INTRINSIC_TIMES:
1053 case INTRINSIC_DIVIDE:
1054 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1055 an integer, we must round towards zero, so we use a
1057 if (expr->ts.type == BT_INTEGER)
1058 code = TRUNC_DIV_EXPR;
1063 case INTRINSIC_POWER:
1064 gfc_conv_power_op (se, expr);
1067 case INTRINSIC_CONCAT:
1068 gfc_conv_concat_op (se, expr);
1072 code = TRUTH_ANDIF_EXPR;
1077 code = TRUTH_ORIF_EXPR;
1081 /* EQV and NEQV only work on logicals, but since we represent them
1082 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1091 case INTRINSIC_NEQV:
1121 case INTRINSIC_USER:
1122 case INTRINSIC_ASSIGN:
1123 /* These should be converted into function calls by the frontend. */
1127 fatal_error ("Unknown intrinsic op");
1131 /* The only exception to this is **, which is handled separately anyway. */
1132 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1134 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1138 gfc_init_se (&lse, se);
1139 gfc_conv_expr (&lse, expr->value.op.op1);
1140 gfc_add_block_to_block (&se->pre, &lse.pre);
1143 gfc_init_se (&rse, se);
1144 gfc_conv_expr (&rse, expr->value.op.op2);
1145 gfc_add_block_to_block (&se->pre, &rse.pre);
1149 gfc_conv_string_parameter (&lse);
1150 gfc_conv_string_parameter (&rse);
1152 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1153 rse.string_length, rse.expr);
1154 rse.expr = integer_zero_node;
1155 gfc_add_block_to_block (&lse.post, &rse.post);
1158 type = gfc_typenode_for_spec (&expr->ts);
1162 /* The result of logical ops is always boolean_type_node. */
1163 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1164 se->expr = convert (type, tmp);
1167 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1169 /* Add the post blocks. */
1170 gfc_add_block_to_block (&se->post, &rse.post);
1171 gfc_add_block_to_block (&se->post, &lse.post);
1174 /* If a string's length is one, we convert it to a single character. */
1177 gfc_to_single_character (tree len, tree str)
1179 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1181 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1182 && TREE_INT_CST_HIGH (len) == 0)
1184 str = fold_convert (pchar_type_node, str);
1185 return build_fold_indirect_ref (str);
1191 /* Compare two strings. If they are all single characters, the result is the
1192 subtraction of them. Otherwise, we build a library call. */
1195 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1202 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1203 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1205 type = gfc_get_int_type (gfc_default_integer_kind);
1207 sc1 = gfc_to_single_character (len1, str1);
1208 sc2 = gfc_to_single_character (len2, str2);
1210 /* Deal with single character specially. */
1211 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1213 sc1 = fold_convert (type, sc1);
1214 sc2 = fold_convert (type, sc2);
1215 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1218 /* Build a call for the comparison. */
1219 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1220 len1, str1, len2, str2);
1225 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1229 if (sym->attr.dummy)
1231 tmp = gfc_get_symbol_decl (sym);
1232 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1233 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1237 if (!sym->backend_decl)
1238 sym->backend_decl = gfc_get_extern_function_decl (sym);
1240 tmp = sym->backend_decl;
1241 if (sym->attr.cray_pointee)
1242 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1243 gfc_get_symbol_decl (sym->cp_pointer));
1244 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1246 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1247 tmp = build_fold_addr_expr (tmp);
1254 /* Translate the call for an elemental subroutine call used in an operator
1255 assignment. This is a simplified version of gfc_conv_function_call. */
1258 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1265 /* Only elemental subroutines with two arguments. */
1266 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1267 gcc_assert (sym->formal->next->next == NULL);
1269 gfc_init_block (&block);
1271 gfc_add_block_to_block (&block, &lse->pre);
1272 gfc_add_block_to_block (&block, &rse->pre);
1274 /* Build the argument list for the call, including hidden string lengths. */
1275 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1276 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1277 if (lse->string_length != NULL_TREE)
1278 args = gfc_chainon_list (args, lse->string_length);
1279 if (rse->string_length != NULL_TREE)
1280 args = gfc_chainon_list (args, rse->string_length);
1282 /* Build the function call. */
1283 gfc_init_se (&se, NULL);
1284 gfc_conv_function_val (&se, sym);
1285 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1286 tmp = build_call_list (tmp, se.expr, args);
1287 gfc_add_expr_to_block (&block, tmp);
1289 gfc_add_block_to_block (&block, &lse->post);
1290 gfc_add_block_to_block (&block, &rse->post);
1292 return gfc_finish_block (&block);
1296 /* Initialize MAPPING. */
1299 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1301 mapping->syms = NULL;
1302 mapping->charlens = NULL;
1306 /* Free all memory held by MAPPING (but not MAPPING itself). */
1309 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1311 gfc_interface_sym_mapping *sym;
1312 gfc_interface_sym_mapping *nextsym;
1314 gfc_charlen *nextcl;
1316 for (sym = mapping->syms; sym; sym = nextsym)
1318 nextsym = sym->next;
1319 gfc_free_symbol (sym->new->n.sym);
1320 gfc_free (sym->new);
1323 for (cl = mapping->charlens; cl; cl = nextcl)
1326 gfc_free_expr (cl->length);
1332 /* Return a copy of gfc_charlen CL. Add the returned structure to
1333 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1335 static gfc_charlen *
1336 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1341 new = gfc_get_charlen ();
1342 new->next = mapping->charlens;
1343 new->length = gfc_copy_expr (cl->length);
1345 mapping->charlens = new;
1350 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1351 array variable that can be used as the actual argument for dummy
1352 argument SYM. Add any initialization code to BLOCK. PACKED is as
1353 for gfc_get_nodesc_array_type and DATA points to the first element
1354 in the passed array. */
1357 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1358 gfc_packed packed, tree data)
1363 type = gfc_typenode_for_spec (&sym->ts);
1364 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1366 var = gfc_create_var (type, "ifm");
1367 gfc_add_modify_expr (block, var, fold_convert (type, data));
1373 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1374 and offset of descriptorless array type TYPE given that it has the same
1375 size as DESC. Add any set-up code to BLOCK. */
1378 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1385 offset = gfc_index_zero_node;
1386 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1388 dim = gfc_rank_cst[n];
1389 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1390 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1392 GFC_TYPE_ARRAY_LBOUND (type, n)
1393 = gfc_conv_descriptor_lbound (desc, dim);
1394 GFC_TYPE_ARRAY_UBOUND (type, n)
1395 = gfc_conv_descriptor_ubound (desc, dim);
1397 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1399 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1400 gfc_conv_descriptor_ubound (desc, dim),
1401 gfc_conv_descriptor_lbound (desc, dim));
1402 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1403 GFC_TYPE_ARRAY_LBOUND (type, n),
1405 tmp = gfc_evaluate_now (tmp, block);
1406 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1408 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1409 GFC_TYPE_ARRAY_LBOUND (type, n),
1410 GFC_TYPE_ARRAY_STRIDE (type, n));
1411 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1413 offset = gfc_evaluate_now (offset, block);
1414 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1418 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1419 in SE. The caller may still use se->expr and se->string_length after
1420 calling this function. */
1423 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1424 gfc_symbol * sym, gfc_se * se)
1426 gfc_interface_sym_mapping *sm;
1430 gfc_symbol *new_sym;
1432 gfc_symtree *new_symtree;
1434 /* Create a new symbol to represent the actual argument. */
1435 new_sym = gfc_new_symbol (sym->name, NULL);
1436 new_sym->ts = sym->ts;
1437 new_sym->attr.referenced = 1;
1438 new_sym->attr.dimension = sym->attr.dimension;
1439 new_sym->attr.pointer = sym->attr.pointer;
1440 new_sym->attr.allocatable = sym->attr.allocatable;
1441 new_sym->attr.flavor = sym->attr.flavor;
1443 /* Create a fake symtree for it. */
1445 new_symtree = gfc_new_symtree (&root, sym->name);
1446 new_symtree->n.sym = new_sym;
1447 gcc_assert (new_symtree == root);
1449 /* Create a dummy->actual mapping. */
1450 sm = gfc_getmem (sizeof (*sm));
1451 sm->next = mapping->syms;
1453 sm->new = new_symtree;
1456 /* Stabilize the argument's value. */
1457 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1459 if (sym->ts.type == BT_CHARACTER)
1461 /* Create a copy of the dummy argument's length. */
1462 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1464 /* If the length is specified as "*", record the length that
1465 the caller is passing. We should use the callee's length
1466 in all other cases. */
1467 if (!new_sym->ts.cl->length)
1469 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1470 new_sym->ts.cl->backend_decl = se->string_length;
1474 /* Use the passed value as-is if the argument is a function. */
1475 if (sym->attr.flavor == FL_PROCEDURE)
1478 /* If the argument is either a string or a pointer to a string,
1479 convert it to a boundless character type. */
1480 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1482 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1483 tmp = build_pointer_type (tmp);
1484 if (sym->attr.pointer)
1485 value = build_fold_indirect_ref (se->expr);
1488 value = fold_convert (tmp, value);
1491 /* If the argument is a scalar, a pointer to an array or an allocatable,
1493 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1494 value = build_fold_indirect_ref (se->expr);
1496 /* For character(*), use the actual argument's descriptor. */
1497 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1498 value = build_fold_indirect_ref (se->expr);
1500 /* If the argument is an array descriptor, use it to determine
1501 information about the actual argument's shape. */
1502 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1503 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1505 /* Get the actual argument's descriptor. */
1506 desc = build_fold_indirect_ref (se->expr);
1508 /* Create the replacement variable. */
1509 tmp = gfc_conv_descriptor_data_get (desc);
1510 value = gfc_get_interface_mapping_array (&se->pre, sym,
1513 /* Use DESC to work out the upper bounds, strides and offset. */
1514 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1517 /* Otherwise we have a packed array. */
1518 value = gfc_get_interface_mapping_array (&se->pre, sym,
1519 PACKED_FULL, se->expr);
1521 new_sym->backend_decl = value;
1525 /* Called once all dummy argument mappings have been added to MAPPING,
1526 but before the mapping is used to evaluate expressions. Pre-evaluate
1527 the length of each argument, adding any initialization code to PRE and
1528 any finalization code to POST. */
1531 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1532 stmtblock_t * pre, stmtblock_t * post)
1534 gfc_interface_sym_mapping *sym;
1538 for (sym = mapping->syms; sym; sym = sym->next)
1539 if (sym->new->n.sym->ts.type == BT_CHARACTER
1540 && !sym->new->n.sym->ts.cl->backend_decl)
1542 expr = sym->new->n.sym->ts.cl->length;
1543 gfc_apply_interface_mapping_to_expr (mapping, expr);
1544 gfc_init_se (&se, NULL);
1545 gfc_conv_expr (&se, expr);
1547 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1548 gfc_add_block_to_block (pre, &se.pre);
1549 gfc_add_block_to_block (post, &se.post);
1551 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1556 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1560 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1561 gfc_constructor * c)
1563 for (; c; c = c->next)
1565 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1568 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1569 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1570 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1576 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1580 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1585 for (; ref; ref = ref->next)
1589 for (n = 0; n < ref->u.ar.dimen; n++)
1591 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1592 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1593 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1595 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1602 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1603 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1609 /* EXPR is a copy of an expression that appeared in the interface
1610 associated with MAPPING. Walk it recursively looking for references to
1611 dummy arguments that MAPPING maps to actual arguments. Replace each such
1612 reference with a reference to the associated actual argument. */
1615 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1618 gfc_interface_sym_mapping *sym;
1619 gfc_actual_arglist *actual;
1620 int seen_result = 0;
1625 /* Copying an expression does not copy its length, so do that here. */
1626 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1628 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1629 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1632 /* Apply the mapping to any references. */
1633 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1635 /* ...and to the expression's symbol, if it has one. */
1637 for (sym = mapping->syms; sym; sym = sym->next)
1638 if (sym->old == expr->symtree->n.sym)
1639 expr->symtree = sym->new;
1641 /* ...and to subexpressions in expr->value. */
1642 switch (expr->expr_type)
1645 if (expr->symtree->n.sym->attr.result)
1649 case EXPR_SUBSTRING:
1653 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1654 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1658 if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1659 && gfc_apply_interface_mapping_to_expr (mapping,
1660 expr->value.function.actual->expr)
1661 && expr->value.function.esym == NULL
1662 && expr->value.function.isym != NULL
1663 && expr->value.function.isym->generic_id == GFC_ISYM_LEN)
1666 new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1668 gfc_free (new_expr);
1669 gfc_apply_interface_mapping_to_expr (mapping, expr);
1673 for (sym = mapping->syms; sym; sym = sym->next)
1674 if (sym->old == expr->value.function.esym)
1675 expr->value.function.esym = sym->new->n.sym;
1677 for (actual = expr->value.function.actual; actual; actual = actual->next)
1678 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1682 case EXPR_STRUCTURE:
1683 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1690 /* Evaluate interface expression EXPR using MAPPING. Store the result
1694 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1695 gfc_se * se, gfc_expr * expr)
1697 expr = gfc_copy_expr (expr);
1698 gfc_apply_interface_mapping_to_expr (mapping, expr);
1699 gfc_conv_expr (se, expr);
1700 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1701 gfc_free_expr (expr);
1704 /* Returns a reference to a temporary array into which a component of
1705 an actual argument derived type array is copied and then returned
1706 after the function call.
1707 TODO Get rid of this kludge, when array descriptors are capable of
1708 handling arrays with a bigger stride in bytes than size. */
1711 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1712 int g77, sym_intent intent)
1728 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1730 gfc_init_se (&lse, NULL);
1731 gfc_init_se (&rse, NULL);
1733 /* Walk the argument expression. */
1734 rss = gfc_walk_expr (expr);
1736 gcc_assert (rss != gfc_ss_terminator);
1738 /* Initialize the scalarizer. */
1739 gfc_init_loopinfo (&loop);
1740 gfc_add_ss_to_loop (&loop, rss);
1742 /* Calculate the bounds of the scalarization. */
1743 gfc_conv_ss_startstride (&loop);
1745 /* Build an ss for the temporary. */
1746 base_type = gfc_typenode_for_spec (&expr->ts);
1747 if (GFC_ARRAY_TYPE_P (base_type)
1748 || GFC_DESCRIPTOR_TYPE_P (base_type))
1749 base_type = gfc_get_element_type (base_type);
1751 loop.temp_ss = gfc_get_ss ();;
1752 loop.temp_ss->type = GFC_SS_TEMP;
1753 loop.temp_ss->data.temp.type = base_type;
1755 if (expr->ts.type == BT_CHARACTER)
1757 gfc_ref *char_ref = expr->ref;
1759 for (; char_ref; char_ref = char_ref->next)
1760 if (char_ref->type == REF_SUBSTRING)
1764 expr->ts.cl = gfc_get_charlen ();
1765 expr->ts.cl->next = char_ref->u.ss.length->next;
1766 char_ref->u.ss.length->next = expr->ts.cl;
1768 gfc_init_se (&tmp_se, NULL);
1769 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1770 gfc_array_index_type);
1771 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1772 tmp_se.expr, gfc_index_one_node);
1773 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1774 gfc_init_se (&tmp_se, NULL);
1775 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1776 gfc_array_index_type);
1777 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1779 expr->ts.cl->backend_decl = tmp;
1783 loop.temp_ss->data.temp.type
1784 = gfc_typenode_for_spec (&expr->ts);
1785 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1788 loop.temp_ss->data.temp.dimen = loop.dimen;
1789 loop.temp_ss->next = gfc_ss_terminator;
1791 /* Associate the SS with the loop. */
1792 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1794 /* Setup the scalarizing loops. */
1795 gfc_conv_loop_setup (&loop);
1797 /* Pass the temporary descriptor back to the caller. */
1798 info = &loop.temp_ss->data.info;
1799 parmse->expr = info->descriptor;
1801 /* Setup the gfc_se structures. */
1802 gfc_copy_loopinfo_to_se (&lse, &loop);
1803 gfc_copy_loopinfo_to_se (&rse, &loop);
1806 lse.ss = loop.temp_ss;
1807 gfc_mark_ss_chain_used (rss, 1);
1808 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1810 /* Start the scalarized loop body. */
1811 gfc_start_scalarized_body (&loop, &body);
1813 /* Translate the expression. */
1814 gfc_conv_expr (&rse, expr);
1816 gfc_conv_tmp_array_ref (&lse);
1817 gfc_advance_se_ss_chain (&lse);
1819 if (intent != INTENT_OUT)
1821 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1822 gfc_add_expr_to_block (&body, tmp);
1823 gcc_assert (rse.ss == gfc_ss_terminator);
1824 gfc_trans_scalarizing_loops (&loop, &body);
1828 /* Make sure that the temporary declaration survives by merging
1829 all the loop declarations into the current context. */
1830 for (n = 0; n < loop.dimen; n++)
1832 gfc_merge_block_scope (&body);
1833 body = loop.code[loop.order[n]];
1835 gfc_merge_block_scope (&body);
1838 /* Add the post block after the second loop, so that any
1839 freeing of allocated memory is done at the right time. */
1840 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1842 /**********Copy the temporary back again.*********/
1844 gfc_init_se (&lse, NULL);
1845 gfc_init_se (&rse, NULL);
1847 /* Walk the argument expression. */
1848 lss = gfc_walk_expr (expr);
1849 rse.ss = loop.temp_ss;
1852 /* Initialize the scalarizer. */
1853 gfc_init_loopinfo (&loop2);
1854 gfc_add_ss_to_loop (&loop2, lss);
1856 /* Calculate the bounds of the scalarization. */
1857 gfc_conv_ss_startstride (&loop2);
1859 /* Setup the scalarizing loops. */
1860 gfc_conv_loop_setup (&loop2);
1862 gfc_copy_loopinfo_to_se (&lse, &loop2);
1863 gfc_copy_loopinfo_to_se (&rse, &loop2);
1865 gfc_mark_ss_chain_used (lss, 1);
1866 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1868 /* Declare the variable to hold the temporary offset and start the
1869 scalarized loop body. */
1870 offset = gfc_create_var (gfc_array_index_type, NULL);
1871 gfc_start_scalarized_body (&loop2, &body);
1873 /* Build the offsets for the temporary from the loop variables. The
1874 temporary array has lbounds of zero and strides of one in all
1875 dimensions, so this is very simple. The offset is only computed
1876 outside the innermost loop, so the overall transfer could be
1877 optimized further. */
1878 info = &rse.ss->data.info;
1880 tmp_index = gfc_index_zero_node;
1881 for (n = info->dimen - 1; n > 0; n--)
1884 tmp = rse.loop->loopvar[n];
1885 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1886 tmp, rse.loop->from[n]);
1887 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1890 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1891 rse.loop->to[n-1], rse.loop->from[n-1]);
1892 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1893 tmp_str, gfc_index_one_node);
1895 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1899 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1900 tmp_index, rse.loop->from[0]);
1901 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1903 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1904 rse.loop->loopvar[0], offset);
1906 /* Now use the offset for the reference. */
1907 tmp = build_fold_indirect_ref (info->data);
1908 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1910 if (expr->ts.type == BT_CHARACTER)
1911 rse.string_length = expr->ts.cl->backend_decl;
1913 gfc_conv_expr (&lse, expr);
1915 gcc_assert (lse.ss == gfc_ss_terminator);
1917 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1918 gfc_add_expr_to_block (&body, tmp);
1920 /* Generate the copying loops. */
1921 gfc_trans_scalarizing_loops (&loop2, &body);
1923 /* Wrap the whole thing up by adding the second loop to the post-block
1924 and following it by the post-block of the first loop. In this way,
1925 if the temporary needs freeing, it is done after use! */
1926 if (intent != INTENT_IN)
1928 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1929 gfc_add_block_to_block (&parmse->post, &loop2.post);
1932 gfc_add_block_to_block (&parmse->post, &loop.post);
1934 gfc_cleanup_loop (&loop);
1935 gfc_cleanup_loop (&loop2);
1937 /* Pass the string length to the argument expression. */
1938 if (expr->ts.type == BT_CHARACTER)
1939 parmse->string_length = expr->ts.cl->backend_decl;
1941 /* We want either the address for the data or the address of the descriptor,
1942 depending on the mode of passing array arguments. */
1944 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1946 parmse->expr = build_fold_addr_expr (parmse->expr);
1951 /* Is true if an array reference is followed by a component or substring
1955 is_aliased_array (gfc_expr * e)
1961 for (ref = e->ref; ref; ref = ref->next)
1963 if (ref->type == REF_ARRAY
1964 && ref->u.ar.type != AR_ELEMENT)
1968 && ref->type != REF_ARRAY)
1974 /* Generate the code for argument list functions. */
1977 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
1979 /* Pass by value for g77 %VAL(arg), pass the address
1980 indirectly for %LOC, else by reference. Thus %REF
1981 is a "do-nothing" and %LOC is the same as an F95
1983 if (strncmp (name, "%VAL", 4) == 0)
1984 gfc_conv_expr (se, expr);
1985 else if (strncmp (name, "%LOC", 4) == 0)
1987 gfc_conv_expr_reference (se, expr);
1988 se->expr = gfc_build_addr_expr (NULL, se->expr);
1990 else if (strncmp (name, "%REF", 4) == 0)
1991 gfc_conv_expr_reference (se, expr);
1993 gfc_error ("Unknown argument list function at %L", &expr->where);
1997 /* Generate code for a procedure call. Note can return se->post != NULL.
1998 If se->direct_byref is set then se->expr contains the return parameter.
1999 Return nonzero, if the call has alternate specifiers. */
2002 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2003 gfc_actual_arglist * arg, tree append_args)
2005 gfc_interface_mapping mapping;
2019 gfc_formal_arglist *formal;
2020 int has_alternate_specifier = 0;
2021 bool need_interface_mapping;
2028 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2030 arglist = NULL_TREE;
2031 retargs = NULL_TREE;
2032 stringargs = NULL_TREE;
2038 if (!sym->attr.elemental)
2040 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2041 if (se->ss->useflags)
2043 gcc_assert (gfc_return_by_reference (sym)
2044 && sym->result->attr.dimension);
2045 gcc_assert (se->loop != NULL);
2047 /* Access the previously obtained result. */
2048 gfc_conv_tmp_array_ref (se);
2049 gfc_advance_se_ss_chain (se);
2053 info = &se->ss->data.info;
2058 gfc_init_block (&post);
2059 gfc_init_interface_mapping (&mapping);
2060 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2061 && sym->ts.cl->length
2062 && sym->ts.cl->length->expr_type
2064 || sym->attr.dimension);
2065 formal = sym->formal;
2066 /* Evaluate the arguments. */
2067 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2070 fsym = formal ? formal->sym : NULL;
2071 parm_kind = MISSING;
2075 if (se->ignore_optional)
2077 /* Some intrinsics have already been resolved to the correct
2081 else if (arg->label)
2083 has_alternate_specifier = 1;
2088 /* Pass a NULL pointer for an absent arg. */
2089 gfc_init_se (&parmse, NULL);
2090 parmse.expr = null_pointer_node;
2091 if (arg->missing_arg_type == BT_CHARACTER)
2092 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2095 else if (se->ss && se->ss->useflags)
2097 /* An elemental function inside a scalarized loop. */
2098 gfc_init_se (&parmse, se);
2099 gfc_conv_expr_reference (&parmse, e);
2100 parm_kind = ELEMENTAL;
2104 /* A scalar or transformational function. */
2105 gfc_init_se (&parmse, NULL);
2106 argss = gfc_walk_expr (e);
2108 if (argss == gfc_ss_terminator)
2111 if (fsym && fsym->attr.value)
2113 gfc_conv_expr (&parmse, e);
2115 else if (arg->name && arg->name[0] == '%')
2116 /* Argument list functions %VAL, %LOC and %REF are signalled
2117 through arg->name. */
2118 conv_arglist_function (&parmse, arg->expr, arg->name);
2119 else if ((e->expr_type == EXPR_FUNCTION)
2120 && e->symtree->n.sym->attr.pointer
2121 && fsym && fsym->attr.target)
2123 gfc_conv_expr (&parmse, e);
2124 parmse.expr = build_fold_addr_expr (parmse.expr);
2128 gfc_conv_expr_reference (&parmse, e);
2129 if (fsym && fsym->attr.pointer
2130 && fsym->attr.flavor != FL_PROCEDURE
2131 && e->expr_type != EXPR_NULL)
2133 /* Scalar pointer dummy args require an extra level of
2134 indirection. The null pointer already contains
2135 this level of indirection. */
2136 parm_kind = SCALAR_POINTER;
2137 parmse.expr = build_fold_addr_expr (parmse.expr);
2143 /* If the procedure requires an explicit interface, the actual
2144 argument is passed according to the corresponding formal
2145 argument. If the corresponding formal argument is a POINTER,
2146 ALLOCATABLE or assumed shape, we do not use g77's calling
2147 convention, and pass the address of the array descriptor
2148 instead. Otherwise we use g77's calling convention. */
2151 && !(fsym->attr.pointer || fsym->attr.allocatable)
2152 && fsym->as->type != AS_ASSUMED_SHAPE;
2153 f = f || !sym->attr.always_explicit;
2155 if (e->expr_type == EXPR_VARIABLE
2156 && is_aliased_array (e))
2157 /* The actual argument is a component reference to an
2158 array of derived types. In this case, the argument
2159 is converted to a temporary, which is passed and then
2160 written back after the procedure call. */
2161 gfc_conv_aliased_arg (&parmse, e, f,
2162 fsym ? fsym->attr.intent : INTENT_INOUT);
2164 gfc_conv_array_parameter (&parmse, e, argss, f);
2166 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2167 allocated on entry, it must be deallocated. */
2168 if (fsym && fsym->attr.allocatable
2169 && fsym->attr.intent == INTENT_OUT)
2171 tmp = build_fold_indirect_ref (parmse.expr);
2172 tmp = gfc_trans_dealloc_allocated (tmp);
2173 gfc_add_expr_to_block (&se->pre, tmp);
2183 /* If an optional argument is itself an optional dummy
2184 argument, check its presence and substitute a null
2186 if (e->expr_type == EXPR_VARIABLE
2187 && e->symtree->n.sym->attr.optional
2188 && fsym->attr.optional)
2189 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2191 /* If an INTENT(OUT) dummy of derived type has a default
2192 initializer, it must be (re)initialized here. */
2193 if (fsym->attr.intent == INTENT_OUT
2194 && fsym->ts.type == BT_DERIVED
2197 gcc_assert (!fsym->attr.allocatable);
2198 tmp = gfc_trans_assignment (e, fsym->value, false);
2199 gfc_add_expr_to_block (&se->pre, tmp);
2202 /* Obtain the character length of an assumed character
2203 length procedure from the typespec. */
2204 if (fsym->ts.type == BT_CHARACTER
2205 && parmse.string_length == NULL_TREE
2206 && e->ts.type == BT_PROCEDURE
2207 && e->symtree->n.sym->ts.type == BT_CHARACTER
2208 && e->symtree->n.sym->ts.cl->length != NULL)
2210 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2211 parmse.string_length
2212 = e->symtree->n.sym->ts.cl->backend_decl;
2216 if (need_interface_mapping)
2217 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2220 gfc_add_block_to_block (&se->pre, &parmse.pre);
2221 gfc_add_block_to_block (&post, &parmse.post);
2223 /* Allocated allocatable components of derived types must be
2224 deallocated for INTENT(OUT) dummy arguments and non-variable
2225 scalars. Non-variable arrays are dealt with in trans-array.c
2226 (gfc_conv_array_parameter). */
2227 if (e && e->ts.type == BT_DERIVED
2228 && e->ts.derived->attr.alloc_comp
2229 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2231 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2234 tmp = build_fold_indirect_ref (parmse.expr);
2235 parm_rank = e->rank;
2243 case (SCALAR_POINTER):
2244 tmp = build_fold_indirect_ref (tmp);
2251 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2252 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2253 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2254 tmp, build_empty_stmt ());
2256 if (e->expr_type != EXPR_VARIABLE)
2257 /* Don't deallocate non-variables until they have been used. */
2258 gfc_add_expr_to_block (&se->post, tmp);
2261 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2262 gfc_add_expr_to_block (&se->pre, tmp);
2266 /* Character strings are passed as two parameters, a length and a
2268 if (parmse.string_length != NULL_TREE)
2269 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2271 arglist = gfc_chainon_list (arglist, parmse.expr);
2273 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2276 if (ts.type == BT_CHARACTER)
2278 if (sym->ts.cl->length == NULL)
2280 /* Assumed character length results are not allowed by 5.1.1.5 of the
2281 standard and are trapped in resolve.c; except in the case of SPREAD
2282 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2283 we take the character length of the first argument for the result.
2284 For dummies, we have to look through the formal argument list for
2285 this function and use the character length found there.*/
2286 if (!sym->attr.dummy)
2287 cl.backend_decl = TREE_VALUE (stringargs);
2290 formal = sym->ns->proc_name->formal;
2291 for (; formal; formal = formal->next)
2292 if (strcmp (formal->sym->name, sym->name) == 0)
2293 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2300 /* Calculate the length of the returned string. */
2301 gfc_init_se (&parmse, NULL);
2302 if (need_interface_mapping)
2303 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2305 gfc_conv_expr (&parmse, sym->ts.cl->length);
2306 gfc_add_block_to_block (&se->pre, &parmse.pre);
2307 gfc_add_block_to_block (&se->post, &parmse.post);
2309 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2310 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2311 build_int_cst (gfc_charlen_type_node, 0));
2312 cl.backend_decl = tmp;
2315 /* Set up a charlen structure for it. */
2320 len = cl.backend_decl;
2323 byref = gfc_return_by_reference (sym);
2326 if (se->direct_byref)
2328 /* Sometimes, too much indirection can be applied; eg. for
2329 function_result = array_valued_recursive_function. */
2330 if (TREE_TYPE (TREE_TYPE (se->expr))
2331 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2332 && GFC_DESCRIPTOR_TYPE_P
2333 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2334 se->expr = build_fold_indirect_ref (se->expr);
2336 retargs = gfc_chainon_list (retargs, se->expr);
2338 else if (sym->result->attr.dimension)
2340 gcc_assert (se->loop && info);
2342 /* Set the type of the array. */
2343 tmp = gfc_typenode_for_spec (&ts);
2344 info->dimen = se->loop->dimen;
2346 /* Evaluate the bounds of the result, if known. */
2347 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2349 /* Create a temporary to store the result. In case the function
2350 returns a pointer, the temporary will be a shallow copy and
2351 mustn't be deallocated. */
2352 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2353 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2354 false, !sym->attr.pointer, callee_alloc);
2356 /* Pass the temporary as the first argument. */
2357 tmp = info->descriptor;
2358 tmp = build_fold_addr_expr (tmp);
2359 retargs = gfc_chainon_list (retargs, tmp);
2361 else if (ts.type == BT_CHARACTER)
2363 /* Pass the string length. */
2364 type = gfc_get_character_type (ts.kind, ts.cl);
2365 type = build_pointer_type (type);
2367 /* Return an address to a char[0:len-1]* temporary for
2368 character pointers. */
2369 if (sym->attr.pointer || sym->attr.allocatable)
2371 /* Build char[0:len-1] * pstr. */
2372 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2373 build_int_cst (gfc_charlen_type_node, 1));
2374 tmp = build_range_type (gfc_array_index_type,
2375 gfc_index_zero_node, tmp);
2376 tmp = build_array_type (gfc_character1_type_node, tmp);
2377 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2379 /* Provide an address expression for the function arguments. */
2380 var = build_fold_addr_expr (var);
2383 var = gfc_conv_string_tmp (se, type, len);
2385 retargs = gfc_chainon_list (retargs, var);
2389 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2391 type = gfc_get_complex_type (ts.kind);
2392 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2393 retargs = gfc_chainon_list (retargs, var);
2396 /* Add the string length to the argument list. */
2397 if (ts.type == BT_CHARACTER)
2398 retargs = gfc_chainon_list (retargs, len);
2400 gfc_free_interface_mapping (&mapping);
2402 /* Add the return arguments. */
2403 arglist = chainon (retargs, arglist);
2405 /* Add the hidden string length parameters to the arguments. */
2406 arglist = chainon (arglist, stringargs);
2408 /* We may want to append extra arguments here. This is used e.g. for
2409 calls to libgfortran_matmul_??, which need extra information. */
2410 if (append_args != NULL_TREE)
2411 arglist = chainon (arglist, append_args);
2413 /* Generate the actual call. */
2414 gfc_conv_function_val (se, sym);
2416 /* If there are alternate return labels, function type should be
2417 integer. Can't modify the type in place though, since it can be shared
2418 with other functions. For dummy arguments, the typing is done to
2419 to this result, even if it has to be repeated for each call. */
2420 if (has_alternate_specifier
2421 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2423 if (!sym->attr.dummy)
2425 TREE_TYPE (sym->backend_decl)
2426 = build_function_type (integer_type_node,
2427 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2428 se->expr = build_fold_addr_expr (sym->backend_decl);
2431 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2434 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2435 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2437 /* If we have a pointer function, but we don't want a pointer, e.g.
2440 where f is pointer valued, we have to dereference the result. */
2441 if (!se->want_pointer && !byref && sym->attr.pointer)
2442 se->expr = build_fold_indirect_ref (se->expr);
2444 /* f2c calling conventions require a scalar default real function to
2445 return a double precision result. Convert this back to default
2446 real. We only care about the cases that can happen in Fortran 77.
2448 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2449 && sym->ts.kind == gfc_default_real_kind
2450 && !sym->attr.always_explicit)
2451 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2453 /* A pure function may still have side-effects - it may modify its
2455 TREE_SIDE_EFFECTS (se->expr) = 1;
2457 if (!sym->attr.pure)
2458 TREE_SIDE_EFFECTS (se->expr) = 1;
2463 /* Add the function call to the pre chain. There is no expression. */
2464 gfc_add_expr_to_block (&se->pre, se->expr);
2465 se->expr = NULL_TREE;
2467 if (!se->direct_byref)
2469 if (sym->attr.dimension)
2471 if (flag_bounds_check)
2473 /* Check the data pointer hasn't been modified. This would
2474 happen in a function returning a pointer. */
2475 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2476 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2478 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2480 se->expr = info->descriptor;
2481 /* Bundle in the string length. */
2482 se->string_length = len;
2484 else if (sym->ts.type == BT_CHARACTER)
2486 /* Dereference for character pointer results. */
2487 if (sym->attr.pointer || sym->attr.allocatable)
2488 se->expr = build_fold_indirect_ref (var);
2492 se->string_length = len;
2496 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2497 se->expr = build_fold_indirect_ref (var);
2502 /* Follow the function call with the argument post block. */
2504 gfc_add_block_to_block (&se->pre, &post);
2506 gfc_add_block_to_block (&se->post, &post);
2508 return has_alternate_specifier;
2512 /* Generate code to copy a string. */
2515 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2516 tree slength, tree src)
2518 tree tmp, dlen, slen;
2526 stmtblock_t tempblock;
2528 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2529 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2531 /* Deal with single character specially. */
2532 dsc = gfc_to_single_character (dlen, dest);
2533 ssc = gfc_to_single_character (slen, src);
2534 if (dsc != NULL_TREE && ssc != NULL_TREE)
2536 gfc_add_modify_expr (block, dsc, ssc);
2540 /* Do nothing if the destination length is zero. */
2541 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2542 build_int_cst (gfc_charlen_type_node, 0));
2544 /* The following code was previously in _gfortran_copy_string:
2546 // The two strings may overlap so we use memmove.
2548 copy_string (GFC_INTEGER_4 destlen, char * dest,
2549 GFC_INTEGER_4 srclen, const char * src)
2551 if (srclen >= destlen)
2553 // This will truncate if too long.
2554 memmove (dest, src, destlen);
2558 memmove (dest, src, srclen);
2560 memset (&dest[srclen], ' ', destlen - srclen);
2564 We're now doing it here for better optimization, but the logic
2567 /* Truncate string if source is too long. */
2568 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2569 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2570 3, dest, src, dlen);
2572 /* Else copy and pad with spaces. */
2573 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2574 3, dest, src, slen);
2576 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2577 fold_convert (pchar_type_node, slen));
2578 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2580 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2581 lang_hooks.to_target_charset (' ')),
2582 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2585 gfc_init_block (&tempblock);
2586 gfc_add_expr_to_block (&tempblock, tmp3);
2587 gfc_add_expr_to_block (&tempblock, tmp4);
2588 tmp3 = gfc_finish_block (&tempblock);
2590 /* The whole copy_string function is there. */
2591 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2592 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2593 gfc_add_expr_to_block (block, tmp);
2597 /* Translate a statement function.
2598 The value of a statement function reference is obtained by evaluating the
2599 expression using the values of the actual arguments for the values of the
2600 corresponding dummy arguments. */
2603 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2607 gfc_formal_arglist *fargs;
2608 gfc_actual_arglist *args;
2611 gfc_saved_var *saved_vars;
2617 sym = expr->symtree->n.sym;
2618 args = expr->value.function.actual;
2619 gfc_init_se (&lse, NULL);
2620 gfc_init_se (&rse, NULL);
2623 for (fargs = sym->formal; fargs; fargs = fargs->next)
2625 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2626 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2628 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2630 /* Each dummy shall be specified, explicitly or implicitly, to be
2632 gcc_assert (fargs->sym->attr.dimension == 0);
2635 /* Create a temporary to hold the value. */
2636 type = gfc_typenode_for_spec (&fsym->ts);
2637 temp_vars[n] = gfc_create_var (type, fsym->name);
2639 if (fsym->ts.type == BT_CHARACTER)
2641 /* Copy string arguments. */
2644 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2645 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2647 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2648 tmp = gfc_build_addr_expr (build_pointer_type (type),
2651 gfc_conv_expr (&rse, args->expr);
2652 gfc_conv_string_parameter (&rse);
2653 gfc_add_block_to_block (&se->pre, &lse.pre);
2654 gfc_add_block_to_block (&se->pre, &rse.pre);
2656 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2658 gfc_add_block_to_block (&se->pre, &lse.post);
2659 gfc_add_block_to_block (&se->pre, &rse.post);
2663 /* For everything else, just evaluate the expression. */
2664 gfc_conv_expr (&lse, args->expr);
2666 gfc_add_block_to_block (&se->pre, &lse.pre);
2667 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2668 gfc_add_block_to_block (&se->pre, &lse.post);
2674 /* Use the temporary variables in place of the real ones. */
2675 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2676 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2678 gfc_conv_expr (se, sym->value);
2680 if (sym->ts.type == BT_CHARACTER)
2682 gfc_conv_const_charlen (sym->ts.cl);
2684 /* Force the expression to the correct length. */
2685 if (!INTEGER_CST_P (se->string_length)
2686 || tree_int_cst_lt (se->string_length,
2687 sym->ts.cl->backend_decl))
2689 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2690 tmp = gfc_create_var (type, sym->name);
2691 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2692 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2693 se->string_length, se->expr);
2696 se->string_length = sym->ts.cl->backend_decl;
2699 /* Restore the original variables. */
2700 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2701 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2702 gfc_free (saved_vars);
2706 /* Translate a function expression. */
2709 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2713 if (expr->value.function.isym)
2715 gfc_conv_intrinsic_function (se, expr);
2719 /* We distinguish statement functions from general functions to improve
2720 runtime performance. */
2721 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2723 gfc_conv_statement_function (se, expr);
2727 /* expr.value.function.esym is the resolved (specific) function symbol for
2728 most functions. However this isn't set for dummy procedures. */
2729 sym = expr->value.function.esym;
2731 sym = expr->symtree->n.sym;
2732 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2737 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2739 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2740 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2742 gfc_conv_tmp_array_ref (se);
2743 gfc_advance_se_ss_chain (se);
2747 /* Build a static initializer. EXPR is the expression for the initial value.
2748 The other parameters describe the variable of the component being
2749 initialized. EXPR may be null. */
2752 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2753 bool array, bool pointer)
2757 if (!(expr || pointer))
2762 /* Arrays need special handling. */
2764 return gfc_build_null_descriptor (type);
2766 return gfc_conv_array_initializer (type, expr);
2769 return fold_convert (type, null_pointer_node);
2775 gfc_init_se (&se, NULL);
2776 gfc_conv_structure (&se, expr, 1);
2780 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2783 gfc_init_se (&se, NULL);
2784 gfc_conv_constant (&se, expr);
2791 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2803 gfc_start_block (&block);
2805 /* Initialize the scalarizer. */
2806 gfc_init_loopinfo (&loop);
2808 gfc_init_se (&lse, NULL);
2809 gfc_init_se (&rse, NULL);
2812 rss = gfc_walk_expr (expr);
2813 if (rss == gfc_ss_terminator)
2815 /* The rhs is scalar. Add a ss for the expression. */
2816 rss = gfc_get_ss ();
2817 rss->next = gfc_ss_terminator;
2818 rss->type = GFC_SS_SCALAR;
2822 /* Create a SS for the destination. */
2823 lss = gfc_get_ss ();
2824 lss->type = GFC_SS_COMPONENT;
2826 lss->shape = gfc_get_shape (cm->as->rank);
2827 lss->next = gfc_ss_terminator;
2828 lss->data.info.dimen = cm->as->rank;
2829 lss->data.info.descriptor = dest;
2830 lss->data.info.data = gfc_conv_array_data (dest);
2831 lss->data.info.offset = gfc_conv_array_offset (dest);
2832 for (n = 0; n < cm->as->rank; n++)
2834 lss->data.info.dim[n] = n;
2835 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2836 lss->data.info.stride[n] = gfc_index_one_node;
2838 mpz_init (lss->shape[n]);
2839 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2840 cm->as->lower[n]->value.integer);
2841 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2844 /* Associate the SS with the loop. */
2845 gfc_add_ss_to_loop (&loop, lss);
2846 gfc_add_ss_to_loop (&loop, rss);
2848 /* Calculate the bounds of the scalarization. */
2849 gfc_conv_ss_startstride (&loop);
2851 /* Setup the scalarizing loops. */
2852 gfc_conv_loop_setup (&loop);
2854 /* Setup the gfc_se structures. */
2855 gfc_copy_loopinfo_to_se (&lse, &loop);
2856 gfc_copy_loopinfo_to_se (&rse, &loop);
2859 gfc_mark_ss_chain_used (rss, 1);
2861 gfc_mark_ss_chain_used (lss, 1);
2863 /* Start the scalarized loop body. */
2864 gfc_start_scalarized_body (&loop, &body);
2866 gfc_conv_tmp_array_ref (&lse);
2867 if (cm->ts.type == BT_CHARACTER)
2868 lse.string_length = cm->ts.cl->backend_decl;
2870 gfc_conv_expr (&rse, expr);
2872 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2873 gfc_add_expr_to_block (&body, tmp);
2875 gcc_assert (rse.ss == gfc_ss_terminator);
2877 /* Generate the copying loops. */
2878 gfc_trans_scalarizing_loops (&loop, &body);
2880 /* Wrap the whole thing up. */
2881 gfc_add_block_to_block (&block, &loop.pre);
2882 gfc_add_block_to_block (&block, &loop.post);
2884 for (n = 0; n < cm->as->rank; n++)
2885 mpz_clear (lss->shape[n]);
2886 gfc_free (lss->shape);
2888 gfc_cleanup_loop (&loop);
2890 return gfc_finish_block (&block);
2894 /* Assign a single component of a derived type constructor. */
2897 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2907 gfc_start_block (&block);
2911 gfc_init_se (&se, NULL);
2912 /* Pointer component. */
2915 /* Array pointer. */
2916 if (expr->expr_type == EXPR_NULL)
2917 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2920 rss = gfc_walk_expr (expr);
2921 se.direct_byref = 1;
2923 gfc_conv_expr_descriptor (&se, expr, rss);
2924 gfc_add_block_to_block (&block, &se.pre);
2925 gfc_add_block_to_block (&block, &se.post);
2930 /* Scalar pointers. */
2931 se.want_pointer = 1;
2932 gfc_conv_expr (&se, expr);
2933 gfc_add_block_to_block (&block, &se.pre);
2934 gfc_add_modify_expr (&block, dest,
2935 fold_convert (TREE_TYPE (dest), se.expr));
2936 gfc_add_block_to_block (&block, &se.post);
2939 else if (cm->dimension)
2941 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2942 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2943 else if (cm->allocatable)
2947 gfc_init_se (&se, NULL);
2949 rss = gfc_walk_expr (expr);
2950 se.want_pointer = 0;
2951 gfc_conv_expr_descriptor (&se, expr, rss);
2952 gfc_add_block_to_block (&block, &se.pre);
2954 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2955 gfc_add_modify_expr (&block, dest, tmp);
2957 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2958 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2961 tmp = gfc_duplicate_allocatable (dest, se.expr,
2962 TREE_TYPE(cm->backend_decl),
2965 gfc_add_expr_to_block (&block, tmp);
2967 gfc_add_block_to_block (&block, &se.post);
2968 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2970 /* Shift the lbound and ubound of temporaries to being unity, rather
2971 than zero, based. Calculate the offset for all cases. */
2972 offset = gfc_conv_descriptor_offset (dest);
2973 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2974 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2975 for (n = 0; n < expr->rank; n++)
2977 if (expr->expr_type != EXPR_VARIABLE
2978 && expr->expr_type != EXPR_CONSTANT)
2980 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2981 gfc_add_modify_expr (&block, tmp,
2982 fold_build2 (PLUS_EXPR,
2983 gfc_array_index_type,
2984 tmp, gfc_index_one_node));
2985 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2986 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2988 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2989 gfc_conv_descriptor_lbound (dest,
2991 gfc_conv_descriptor_stride (dest,
2993 gfc_add_modify_expr (&block, tmp2, tmp);
2994 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2995 gfc_add_modify_expr (&block, offset, tmp);
3000 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3001 gfc_add_expr_to_block (&block, tmp);
3004 else if (expr->ts.type == BT_DERIVED)
3006 if (expr->expr_type != EXPR_STRUCTURE)
3008 gfc_init_se (&se, NULL);
3009 gfc_conv_expr (&se, expr);
3010 gfc_add_modify_expr (&block, dest,
3011 fold_convert (TREE_TYPE (dest), se.expr));
3015 /* Nested constructors. */
3016 tmp = gfc_trans_structure_assign (dest, expr);
3017 gfc_add_expr_to_block (&block, tmp);
3022 /* Scalar component. */
3023 gfc_init_se (&se, NULL);
3024 gfc_init_se (&lse, NULL);
3026 gfc_conv_expr (&se, expr);
3027 if (cm->ts.type == BT_CHARACTER)
3028 lse.string_length = cm->ts.cl->backend_decl;
3030 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3031 gfc_add_expr_to_block (&block, tmp);
3033 return gfc_finish_block (&block);
3036 /* Assign a derived type constructor to a variable. */
3039 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3047 gfc_start_block (&block);
3048 cm = expr->ts.derived->components;
3049 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3051 /* Skip absent members in default initializers. */
3055 field = cm->backend_decl;
3056 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3057 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3058 gfc_add_expr_to_block (&block, tmp);
3060 return gfc_finish_block (&block);
3063 /* Build an expression for a constructor. If init is nonzero then
3064 this is part of a static variable initializer. */
3067 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3074 VEC(constructor_elt,gc) *v = NULL;
3076 gcc_assert (se->ss == NULL);
3077 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3078 type = gfc_typenode_for_spec (&expr->ts);
3082 /* Create a temporary variable and fill it in. */
3083 se->expr = gfc_create_var (type, expr->ts.derived->name);
3084 tmp = gfc_trans_structure_assign (se->expr, expr);
3085 gfc_add_expr_to_block (&se->pre, tmp);
3089 cm = expr->ts.derived->components;
3091 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3093 /* Skip absent members in default initializers and allocatable
3094 components. Although the latter have a default initializer
3095 of EXPR_NULL,... by default, the static nullify is not needed
3096 since this is done every time we come into scope. */
3097 if (!c->expr || cm->allocatable)
3100 val = gfc_conv_initializer (c->expr, &cm->ts,
3101 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3103 /* Append it to the constructor list. */
3104 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3106 se->expr = build_constructor (type, v);
3110 /* Translate a substring expression. */
3113 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3119 gcc_assert (ref->type == REF_SUBSTRING);
3121 se->expr = gfc_build_string_const(expr->value.character.length,
3122 expr->value.character.string);
3123 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3124 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3126 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3130 /* Entry point for expression translation. Evaluates a scalar quantity.
3131 EXPR is the expression to be translated, and SE is the state structure if
3132 called from within the scalarized. */
3135 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3137 if (se->ss && se->ss->expr == expr
3138 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3140 /* Substitute a scalar expression evaluated outside the scalarization
3142 se->expr = se->ss->data.scalar.expr;
3143 se->string_length = se->ss->string_length;
3144 gfc_advance_se_ss_chain (se);
3148 switch (expr->expr_type)
3151 gfc_conv_expr_op (se, expr);
3155 gfc_conv_function_expr (se, expr);
3159 gfc_conv_constant (se, expr);
3163 gfc_conv_variable (se, expr);
3167 se->expr = null_pointer_node;
3170 case EXPR_SUBSTRING:
3171 gfc_conv_substring_expr (se, expr);
3174 case EXPR_STRUCTURE:
3175 gfc_conv_structure (se, expr, 0);
3179 gfc_conv_array_constructor_expr (se, expr);
3188 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3189 of an assignment. */
3191 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3193 gfc_conv_expr (se, expr);
3194 /* All numeric lvalues should have empty post chains. If not we need to
3195 figure out a way of rewriting an lvalue so that it has no post chain. */
3196 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3199 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3200 numeric expressions. Used for scalar values where inserting cleanup code
3203 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3207 gcc_assert (expr->ts.type != BT_CHARACTER);
3208 gfc_conv_expr (se, expr);
3211 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3212 gfc_add_modify_expr (&se->pre, val, se->expr);
3214 gfc_add_block_to_block (&se->pre, &se->post);
3218 /* Helper to translate and expression and convert it to a particular type. */
3220 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3222 gfc_conv_expr_val (se, expr);
3223 se->expr = convert (type, se->expr);
3227 /* Converts an expression so that it can be passed by reference. Scalar
3231 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3235 if (se->ss && se->ss->expr == expr
3236 && se->ss->type == GFC_SS_REFERENCE)
3238 se->expr = se->ss->data.scalar.expr;
3239 se->string_length = se->ss->string_length;
3240 gfc_advance_se_ss_chain (se);
3244 if (expr->ts.type == BT_CHARACTER)
3246 gfc_conv_expr (se, expr);
3247 gfc_conv_string_parameter (se);
3251 if (expr->expr_type == EXPR_VARIABLE)
3253 se->want_pointer = 1;
3254 gfc_conv_expr (se, expr);
3257 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3258 gfc_add_modify_expr (&se->pre, var, se->expr);
3259 gfc_add_block_to_block (&se->pre, &se->post);
3265 gfc_conv_expr (se, expr);
3267 /* Create a temporary var to hold the value. */
3268 if (TREE_CONSTANT (se->expr))
3270 tree tmp = se->expr;
3271 STRIP_TYPE_NOPS (tmp);
3272 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3273 DECL_INITIAL (var) = tmp;
3274 TREE_STATIC (var) = 1;
3279 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3280 gfc_add_modify_expr (&se->pre, var, se->expr);
3282 gfc_add_block_to_block (&se->pre, &se->post);
3284 /* Take the address of that value. */
3285 se->expr = build_fold_addr_expr (var);
3290 gfc_trans_pointer_assign (gfc_code * code)
3292 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3296 /* Generate code for a pointer assignment. */
3299 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3309 gfc_start_block (&block);
3311 gfc_init_se (&lse, NULL);
3313 lss = gfc_walk_expr (expr1);
3314 rss = gfc_walk_expr (expr2);
3315 if (lss == gfc_ss_terminator)
3317 /* Scalar pointers. */
3318 lse.want_pointer = 1;
3319 gfc_conv_expr (&lse, expr1);
3320 gcc_assert (rss == gfc_ss_terminator);
3321 gfc_init_se (&rse, NULL);
3322 rse.want_pointer = 1;
3323 gfc_conv_expr (&rse, expr2);
3324 gfc_add_block_to_block (&block, &lse.pre);
3325 gfc_add_block_to_block (&block, &rse.pre);
3326 gfc_add_modify_expr (&block, lse.expr,
3327 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3328 gfc_add_block_to_block (&block, &rse.post);
3329 gfc_add_block_to_block (&block, &lse.post);
3333 /* Array pointer. */
3334 gfc_conv_expr_descriptor (&lse, expr1, lss);
3335 switch (expr2->expr_type)
3338 /* Just set the data pointer to null. */
3339 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3343 /* Assign directly to the pointer's descriptor. */
3344 lse.direct_byref = 1;
3345 gfc_conv_expr_descriptor (&lse, expr2, rss);
3349 /* Assign to a temporary descriptor and then copy that
3350 temporary to the pointer. */
3352 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3355 lse.direct_byref = 1;
3356 gfc_conv_expr_descriptor (&lse, expr2, rss);
3357 gfc_add_modify_expr (&lse.pre, desc, tmp);
3360 gfc_add_block_to_block (&block, &lse.pre);
3361 gfc_add_block_to_block (&block, &lse.post);
3363 return gfc_finish_block (&block);
3367 /* Makes sure se is suitable for passing as a function string parameter. */
3368 /* TODO: Need to check all callers fo this function. It may be abused. */
3371 gfc_conv_string_parameter (gfc_se * se)
3375 if (TREE_CODE (se->expr) == STRING_CST)
3377 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3381 type = TREE_TYPE (se->expr);
3382 if (TYPE_STRING_FLAG (type))
3384 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3385 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3388 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3389 gcc_assert (se->string_length
3390 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3394 /* Generate code for assignment of scalar variables. Includes character
3395 strings and derived types with allocatable components. */
3398 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3399 bool l_is_temp, bool r_is_var)
3405 gfc_init_block (&block);
3407 if (ts.type == BT_CHARACTER)
3409 gcc_assert (lse->string_length != NULL_TREE
3410 && rse->string_length != NULL_TREE);
3412 gfc_conv_string_parameter (lse);
3413 gfc_conv_string_parameter (rse);
3415 gfc_add_block_to_block (&block, &lse->pre);
3416 gfc_add_block_to_block (&block, &rse->pre);
3418 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3419 rse->string_length, rse->expr);
3421 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3425 /* Are the rhs and the lhs the same? */
3428 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3429 build_fold_addr_expr (lse->expr),
3430 build_fold_addr_expr (rse->expr));
3431 cond = gfc_evaluate_now (cond, &lse->pre);
3434 /* Deallocate the lhs allocated components as long as it is not
3435 the same as the rhs. */
3438 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3440 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3441 gfc_add_expr_to_block (&lse->pre, tmp);
3444 gfc_add_block_to_block (&block, &lse->pre);
3445 gfc_add_block_to_block (&block, &rse->pre);
3447 gfc_add_modify_expr (&block, lse->expr,
3448 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3450 /* Do a deep copy if the rhs is a variable, if it is not the
3454 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3455 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3456 gfc_add_expr_to_block (&block, tmp);
3461 gfc_add_block_to_block (&block, &lse->pre);
3462 gfc_add_block_to_block (&block, &rse->pre);
3464 gfc_add_modify_expr (&block, lse->expr,
3465 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3468 gfc_add_block_to_block (&block, &lse->post);
3469 gfc_add_block_to_block (&block, &rse->post);
3471 return gfc_finish_block (&block);
3475 /* Try to translate array(:) = func (...), where func is a transformational
3476 array function, without using a temporary. Returns NULL is this isn't the
3480 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3485 bool seen_array_ref;
3487 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3488 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3491 /* Elemental functions don't need a temporary anyway. */
3492 if (expr2->value.function.esym != NULL
3493 && expr2->value.function.esym->attr.elemental)
3496 /* Fail if EXPR1 can't be expressed as a descriptor. */
3497 if (gfc_ref_needs_temporary_p (expr1->ref))
3500 /* Functions returning pointers need temporaries. */
3501 if (expr2->symtree->n.sym->attr.pointer
3502 || expr2->symtree->n.sym->attr.allocatable)
3505 /* Character array functions need temporaries unless the
3506 character lengths are the same. */
3507 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3509 if (expr1->ts.cl->length == NULL
3510 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3513 if (expr2->ts.cl->length == NULL
3514 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3517 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3518 expr2->ts.cl->length->value.integer) != 0)
3522 /* Check that no LHS component references appear during an array
3523 reference. This is needed because we do not have the means to
3524 span any arbitrary stride with an array descriptor. This check
3525 is not needed for the rhs because the function result has to be
3527 seen_array_ref = false;
3528 for (ref = expr1->ref; ref; ref = ref->next)
3530 if (ref->type == REF_ARRAY)
3531 seen_array_ref= true;
3532 else if (ref->type == REF_COMPONENT && seen_array_ref)
3536 /* Check for a dependency. */
3537 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3538 expr2->value.function.esym,
3539 expr2->value.function.actual))
3542 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3544 gcc_assert (expr2->value.function.isym
3545 || (gfc_return_by_reference (expr2->value.function.esym)
3546 && expr2->value.function.esym->result->attr.dimension));
3548 ss = gfc_walk_expr (expr1);
3549 gcc_assert (ss != gfc_ss_terminator);
3550 gfc_init_se (&se, NULL);
3551 gfc_start_block (&se.pre);
3552 se.want_pointer = 1;
3554 gfc_conv_array_parameter (&se, expr1, ss, 0);
3556 se.direct_byref = 1;
3557 se.ss = gfc_walk_expr (expr2);
3558 gcc_assert (se.ss != gfc_ss_terminator);
3559 gfc_conv_function_expr (&se, expr2);
3560 gfc_add_block_to_block (&se.pre, &se.post);
3562 return gfc_finish_block (&se.pre);
3565 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3568 is_zero_initializer_p (gfc_expr * expr)
3570 if (expr->expr_type != EXPR_CONSTANT)
3572 /* We ignore Hollerith constants for the time being. */
3576 switch (expr->ts.type)
3579 return mpz_cmp_si (expr->value.integer, 0) == 0;
3582 return mpfr_zero_p (expr->value.real)
3583 && MPFR_SIGN (expr->value.real) >= 0;
3586 return expr->value.logical == 0;
3589 return mpfr_zero_p (expr->value.complex.r)
3590 && MPFR_SIGN (expr->value.complex.r) >= 0
3591 && mpfr_zero_p (expr->value.complex.i)
3592 && MPFR_SIGN (expr->value.complex.i) >= 0;
3600 /* Try to efficiently translate array(:) = 0. Return NULL if this
3604 gfc_trans_zero_assign (gfc_expr * expr)
3606 tree dest, len, type;
3610 sym = expr->symtree->n.sym;
3611 dest = gfc_get_symbol_decl (sym);
3613 type = TREE_TYPE (dest);
3614 if (POINTER_TYPE_P (type))
3615 type = TREE_TYPE (type);
3616 if (!GFC_ARRAY_TYPE_P (type))
3619 /* Determine the length of the array. */
3620 len = GFC_TYPE_ARRAY_SIZE (type);
3621 if (!len || TREE_CODE (len) != INTEGER_CST)
3624 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3625 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
3627 /* Convert arguments to the correct types. */
3628 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3629 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3631 dest = fold_convert (pvoid_type_node, dest);
3632 len = fold_convert (size_type_node, len);
3634 /* Construct call to __builtin_memset. */
3635 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3636 3, dest, integer_zero_node, len);
3637 return fold_convert (void_type_node, tmp);
3641 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3642 that constructs the call to __builtin_memcpy. */
3645 gfc_build_memcpy_call (tree dst, tree src, tree len)
3649 /* Convert arguments to the correct types. */
3650 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3651 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3653 dst = fold_convert (pvoid_type_node, dst);
3655 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3656 src = gfc_build_addr_expr (pvoid_type_node, src);
3658 src = fold_convert (pvoid_type_node, src);
3660 len = fold_convert (size_type_node, len);
3662 /* Construct call to __builtin_memcpy. */
3663 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3664 return fold_convert (void_type_node, tmp);
3668 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3669 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3670 source/rhs, both are gfc_full_array_ref_p which have been checked for
3674 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3676 tree dst, dlen, dtype;
3677 tree src, slen, stype;
3679 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3680 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3682 dtype = TREE_TYPE (dst);
3683 if (POINTER_TYPE_P (dtype))
3684 dtype = TREE_TYPE (dtype);
3685 stype = TREE_TYPE (src);
3686 if (POINTER_TYPE_P (stype))
3687 stype = TREE_TYPE (stype);
3689 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3692 /* Determine the lengths of the arrays. */
3693 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3694 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3696 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3697 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3699 slen = GFC_TYPE_ARRAY_SIZE (stype);
3700 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3702 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3703 TYPE_SIZE_UNIT (gfc_get_element_type (stype)));
3705 /* Sanity check that they are the same. This should always be
3706 the case, as we should already have checked for conformance. */
3707 if (!tree_int_cst_equal (slen, dlen))
3710 return gfc_build_memcpy_call (dst, src, dlen);
3714 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3715 this can't be done. EXPR1 is the destination/lhs for which
3716 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3719 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3721 unsigned HOST_WIDE_INT nelem;
3726 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3730 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3731 dtype = TREE_TYPE (dst);
3732 if (POINTER_TYPE_P (dtype))
3733 dtype = TREE_TYPE (dtype);
3734 if (!GFC_ARRAY_TYPE_P (dtype))
3737 /* Determine the lengths of the array. */
3738 len = GFC_TYPE_ARRAY_SIZE (dtype);
3739 if (!len || TREE_CODE (len) != INTEGER_CST)
3742 /* Confirm that the constructor is the same size. */
3743 if (compare_tree_int (len, nelem) != 0)
3746 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3747 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3749 stype = gfc_typenode_for_spec (&expr2->ts);
3750 src = gfc_build_constant_array_constructor (expr2, stype);
3752 stype = TREE_TYPE (src);
3753 if (POINTER_TYPE_P (stype))
3754 stype = TREE_TYPE (stype);
3756 return gfc_build_memcpy_call (dst, src, len);
3760 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3761 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3764 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3769 gfc_ss *lss_section;
3777 /* Assignment of the form lhs = rhs. */
3778 gfc_start_block (&block);
3780 gfc_init_se (&lse, NULL);
3781 gfc_init_se (&rse, NULL);
3784 lss = gfc_walk_expr (expr1);
3786 if (lss != gfc_ss_terminator)
3788 /* The assignment needs scalarization. */
3791 /* Find a non-scalar SS from the lhs. */
3792 while (lss_section != gfc_ss_terminator
3793 && lss_section->type != GFC_SS_SECTION)
3794 lss_section = lss_section->next;
3796 gcc_assert (lss_section != gfc_ss_terminator);
3798 /* Initialize the scalarizer. */
3799 gfc_init_loopinfo (&loop);
3802 rss = gfc_walk_expr (expr2);
3803 if (rss == gfc_ss_terminator)
3805 /* The rhs is scalar. Add a ss for the expression. */
3806 rss = gfc_get_ss ();
3807 rss->next = gfc_ss_terminator;
3808 rss->type = GFC_SS_SCALAR;
3811 /* Associate the SS with the loop. */
3812 gfc_add_ss_to_loop (&loop, lss);
3813 gfc_add_ss_to_loop (&loop, rss);
3815 /* Calculate the bounds of the scalarization. */
3816 gfc_conv_ss_startstride (&loop);
3817 /* Resolve any data dependencies in the statement. */
3818 gfc_conv_resolve_dependencies (&loop, lss, rss);
3819 /* Setup the scalarizing loops. */
3820 gfc_conv_loop_setup (&loop);
3822 /* Setup the gfc_se structures. */
3823 gfc_copy_loopinfo_to_se (&lse, &loop);
3824 gfc_copy_loopinfo_to_se (&rse, &loop);
3827 gfc_mark_ss_chain_used (rss, 1);
3828 if (loop.temp_ss == NULL)
3831 gfc_mark_ss_chain_used (lss, 1);
3835 lse.ss = loop.temp_ss;
3836 gfc_mark_ss_chain_used (lss, 3);
3837 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3840 /* Start the scalarized loop body. */
3841 gfc_start_scalarized_body (&loop, &body);
3844 gfc_init_block (&body);
3846 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3848 /* Translate the expression. */
3849 gfc_conv_expr (&rse, expr2);
3853 gfc_conv_tmp_array_ref (&lse);
3854 gfc_advance_se_ss_chain (&lse);
3857 gfc_conv_expr (&lse, expr1);
3859 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3860 l_is_temp || init_flag,
3861 expr2->expr_type == EXPR_VARIABLE);
3862 gfc_add_expr_to_block (&body, tmp);
3864 if (lss == gfc_ss_terminator)
3866 /* Use the scalar assignment as is. */
3867 gfc_add_block_to_block (&block, &body);
3871 gcc_assert (lse.ss == gfc_ss_terminator
3872 && rse.ss == gfc_ss_terminator);
3876 gfc_trans_scalarized_loop_boundary (&loop, &body);
3878 /* We need to copy the temporary to the actual lhs. */
3879 gfc_init_se (&lse, NULL);
3880 gfc_init_se (&rse, NULL);
3881 gfc_copy_loopinfo_to_se (&lse, &loop);
3882 gfc_copy_loopinfo_to_se (&rse, &loop);
3884 rse.ss = loop.temp_ss;
3887 gfc_conv_tmp_array_ref (&rse);
3888 gfc_advance_se_ss_chain (&rse);
3889 gfc_conv_expr (&lse, expr1);
3891 gcc_assert (lse.ss == gfc_ss_terminator
3892 && rse.ss == gfc_ss_terminator);
3894 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3896 gfc_add_expr_to_block (&body, tmp);
3899 /* Generate the copying loops. */
3900 gfc_trans_scalarizing_loops (&loop, &body);
3902 /* Wrap the whole thing up. */
3903 gfc_add_block_to_block (&block, &loop.pre);
3904 gfc_add_block_to_block (&block, &loop.post);
3906 gfc_cleanup_loop (&loop);
3909 return gfc_finish_block (&block);
3913 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3916 copyable_array_p (gfc_expr * expr)
3918 /* First check it's an array. */
3919 if (expr->rank < 1 || !expr->ref)
3922 /* Next check that it's of a simple enough type. */
3923 switch (expr->ts.type)
3935 return !expr->ts.derived->attr.alloc_comp;
3944 /* Translate an assignment. */
3947 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3951 /* Special case a single function returning an array. */
3952 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3954 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3959 /* Special case assigning an array to zero. */
3960 if (expr1->expr_type == EXPR_VARIABLE
3963 && expr1->ref->next == NULL
3964 && gfc_full_array_ref_p (expr1->ref)
3965 && is_zero_initializer_p (expr2))
3967 tmp = gfc_trans_zero_assign (expr1);
3972 /* Special case copying one array to another. */
3973 if (expr1->expr_type == EXPR_VARIABLE
3974 && copyable_array_p (expr1)
3975 && gfc_full_array_ref_p (expr1->ref)
3976 && expr2->expr_type == EXPR_VARIABLE
3977 && copyable_array_p (expr2)
3978 && gfc_full_array_ref_p (expr2->ref)
3979 && gfc_compare_types (&expr1->ts, &expr2->ts)
3980 && !gfc_check_dependency (expr1, expr2, 0))
3982 tmp = gfc_trans_array_copy (expr1, expr2);
3987 /* Special case initializing an array from a constant array constructor. */
3988 if (expr1->expr_type == EXPR_VARIABLE
3989 && copyable_array_p (expr1)
3990 && gfc_full_array_ref_p (expr1->ref)
3991 && expr2->expr_type == EXPR_ARRAY
3992 && gfc_compare_types (&expr1->ts, &expr2->ts))
3994 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
3999 /* Fallback to the scalarizer to generate explicit loops. */
4000 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4004 gfc_trans_init_assign (gfc_code * code)
4006 return gfc_trans_assignment (code->expr, code->expr2, true);
4010 gfc_trans_assign (gfc_code * code)
4012 return gfc_trans_assignment (code->expr, code->expr2, false);