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 /* Change the start of the string. */
265 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
268 tmp = build_fold_indirect_ref (se->expr);
269 tmp = gfc_build_array_ref (tmp, start.expr);
270 se->expr = gfc_build_addr_expr (type, tmp);
273 /* Length = end + 1 - start. */
274 gfc_init_se (&end, se);
275 if (ref->u.ss.end == NULL)
276 end.expr = se->string_length;
279 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
280 gfc_add_block_to_block (&se->pre, &end.pre);
282 if (flag_bounds_check)
284 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
285 start.expr, end.expr);
287 /* Check lower bound. */
288 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
289 build_int_cst (gfc_charlen_type_node, 1));
290 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
293 asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
294 "is less than one", name);
296 asprintf (&msg, "Substring out of bounds: lower bound "
298 gfc_trans_runtime_check (fault, msg, &se->pre, where);
301 /* Check upper bound. */
302 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
304 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
307 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
308 "exceeds string length", name);
310 asprintf (&msg, "Substring out of bounds: upper bound "
311 "exceeds string length");
312 gfc_trans_runtime_check (fault, msg, &se->pre, where);
316 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
317 build_int_cst (gfc_charlen_type_node, 1),
319 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
320 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
321 build_int_cst (gfc_charlen_type_node, 0));
322 se->string_length = tmp;
326 /* Convert a derived type component reference. */
329 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
336 c = ref->u.c.component;
338 gcc_assert (c->backend_decl);
340 field = c->backend_decl;
341 gcc_assert (TREE_CODE (field) == FIELD_DECL);
343 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
347 if (c->ts.type == BT_CHARACTER)
349 tmp = c->ts.cl->backend_decl;
350 /* Components must always be constant length. */
351 gcc_assert (tmp && INTEGER_CST_P (tmp));
352 se->string_length = tmp;
355 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
356 se->expr = build_fold_indirect_ref (se->expr);
360 /* Return the contents of a variable. Also handles reference/pointer
361 variables (all Fortran pointer references are implicit). */
364 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
371 bool alternate_entry;
374 sym = expr->symtree->n.sym;
377 /* Check that something hasn't gone horribly wrong. */
378 gcc_assert (se->ss != gfc_ss_terminator);
379 gcc_assert (se->ss->expr == expr);
381 /* A scalarized term. We already know the descriptor. */
382 se->expr = se->ss->data.info.descriptor;
383 se->string_length = se->ss->string_length;
384 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
385 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
390 tree se_expr = NULL_TREE;
392 se->expr = gfc_get_symbol_decl (sym);
394 /* Deal with references to a parent results or entries by storing
395 the current_function_decl and moving to the parent_decl. */
396 return_value = sym->attr.function && sym->result == sym;
397 alternate_entry = sym->attr.function && sym->attr.entry
398 && sym->result == sym;
399 entry_master = sym->attr.result
400 && sym->ns->proc_name->attr.entry_master
401 && !gfc_return_by_reference (sym->ns->proc_name);
402 parent_decl = DECL_CONTEXT (current_function_decl);
404 if ((se->expr == parent_decl && return_value)
405 || (sym->ns && sym->ns->proc_name
407 && sym->ns->proc_name->backend_decl == parent_decl
408 && (alternate_entry || entry_master)))
413 /* Special case for assigning the return value of a function.
414 Self recursive functions must have an explicit return value. */
415 if (return_value && (se->expr == current_function_decl || parent_flag))
416 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
418 /* Similarly for alternate entry points. */
419 else if (alternate_entry
420 && (sym->ns->proc_name->backend_decl == current_function_decl
423 gfc_entry_list *el = NULL;
425 for (el = sym->ns->entries; el; el = el->next)
428 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
433 else if (entry_master
434 && (sym->ns->proc_name->backend_decl == current_function_decl
436 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
441 /* Procedure actual arguments. */
442 else if (sym->attr.flavor == FL_PROCEDURE
443 && se->expr != current_function_decl)
445 gcc_assert (se->want_pointer);
446 if (!sym->attr.dummy)
448 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
449 se->expr = build_fold_addr_expr (se->expr);
455 /* Dereference the expression, where needed. Since characters
456 are entirely different from other types, they are treated
458 if (sym->ts.type == BT_CHARACTER)
460 /* Dereference character pointer dummy arguments
462 if ((sym->attr.pointer || sym->attr.allocatable)
464 || sym->attr.function
465 || sym->attr.result))
466 se->expr = build_fold_indirect_ref (se->expr);
468 /* A character with VALUE attribute needs an address
471 se->expr = build_fold_addr_expr (se->expr);
474 else if (!sym->attr.value)
476 /* Dereference non-character scalar dummy arguments. */
477 if (sym->attr.dummy && !sym->attr.dimension)
478 se->expr = build_fold_indirect_ref (se->expr);
480 /* Dereference scalar hidden result. */
481 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
482 && (sym->attr.function || sym->attr.result)
483 && !sym->attr.dimension && !sym->attr.pointer)
484 se->expr = build_fold_indirect_ref (se->expr);
486 /* Dereference non-character pointer variables.
487 These must be dummies, results, or scalars. */
488 if ((sym->attr.pointer || sym->attr.allocatable)
490 || sym->attr.function
492 || !sym->attr.dimension))
493 se->expr = build_fold_indirect_ref (se->expr);
499 /* For character variables, also get the length. */
500 if (sym->ts.type == BT_CHARACTER)
502 /* If the character length of an entry isn't set, get the length from
503 the master function instead. */
504 if (sym->attr.entry && !sym->ts.cl->backend_decl)
505 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
507 se->string_length = sym->ts.cl->backend_decl;
508 gcc_assert (se->string_length);
516 /* Return the descriptor if that's what we want and this is an array
517 section reference. */
518 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
520 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
521 /* Return the descriptor for array pointers and allocations. */
523 && ref->next == NULL && (se->descriptor_only))
526 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
527 /* Return a pointer to an element. */
531 gfc_conv_component_ref (se, ref);
535 gfc_conv_substring (se, ref, expr->ts.kind,
536 expr->symtree->name, &expr->where);
545 /* Pointer assignment, allocation or pass by reference. Arrays are handled
547 if (se->want_pointer)
549 if (expr->ts.type == BT_CHARACTER)
550 gfc_conv_string_parameter (se);
552 se->expr = build_fold_addr_expr (se->expr);
557 /* Unary ops are easy... Or they would be if ! was a valid op. */
560 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
565 gcc_assert (expr->ts.type != BT_CHARACTER);
566 /* Initialize the operand. */
567 gfc_init_se (&operand, se);
568 gfc_conv_expr_val (&operand, expr->value.op.op1);
569 gfc_add_block_to_block (&se->pre, &operand.pre);
571 type = gfc_typenode_for_spec (&expr->ts);
573 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
574 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
575 All other unary operators have an equivalent GIMPLE unary operator. */
576 if (code == TRUTH_NOT_EXPR)
577 se->expr = build2 (EQ_EXPR, type, operand.expr,
578 build_int_cst (type, 0));
580 se->expr = build1 (code, type, operand.expr);
584 /* Expand power operator to optimal multiplications when a value is raised
585 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
586 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
587 Programming", 3rd Edition, 1998. */
589 /* This code is mostly duplicated from expand_powi in the backend.
590 We establish the "optimal power tree" lookup table with the defined size.
591 The items in the table are the exponents used to calculate the index
592 exponents. Any integer n less than the value can get an "addition chain",
593 with the first node being one. */
594 #define POWI_TABLE_SIZE 256
596 /* The table is from builtins.c. */
597 static const unsigned char powi_table[POWI_TABLE_SIZE] =
599 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
600 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
601 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
602 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
603 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
604 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
605 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
606 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
607 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
608 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
609 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
610 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
611 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
612 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
613 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
614 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
615 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
616 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
617 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
618 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
619 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
620 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
621 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
622 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
623 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
624 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
625 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
626 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
627 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
628 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
629 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
630 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
633 /* If n is larger than lookup table's max index, we use the "window
635 #define POWI_WINDOW_SIZE 3
637 /* Recursive function to expand the power operator. The temporary
638 values are put in tmpvar. The function returns tmpvar[1] ** n. */
640 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
647 if (n < POWI_TABLE_SIZE)
652 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
653 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
657 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
658 op0 = gfc_conv_powi (se, n - digit, tmpvar);
659 op1 = gfc_conv_powi (se, digit, tmpvar);
663 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
667 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
668 tmp = gfc_evaluate_now (tmp, &se->pre);
670 if (n < POWI_TABLE_SIZE)
677 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
678 return 1. Else return 0 and a call to runtime library functions
679 will have to be built. */
681 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
686 tree vartmp[POWI_TABLE_SIZE];
688 unsigned HOST_WIDE_INT n;
691 /* If exponent is too large, we won't expand it anyway, so don't bother
692 with large integer values. */
693 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
696 m = double_int_to_shwi (TREE_INT_CST (rhs));
697 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
698 of the asymmetric range of the integer type. */
699 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
701 type = TREE_TYPE (lhs);
702 sgn = tree_int_cst_sgn (rhs);
704 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
705 || optimize_size) && (m > 2 || m < -1))
711 se->expr = gfc_build_const (type, integer_one_node);
715 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
716 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
718 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
719 build_int_cst (TREE_TYPE (lhs), -1));
720 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
721 build_int_cst (TREE_TYPE (lhs), 1));
724 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
727 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
728 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
729 build_int_cst (type, 0));
733 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
734 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
735 build_int_cst (type, 0));
736 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
740 memset (vartmp, 0, sizeof (vartmp));
744 tmp = gfc_build_const (type, integer_one_node);
745 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
748 se->expr = gfc_conv_powi (se, n, vartmp);
754 /* Power op (**). Constant integer exponent has special handling. */
757 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
759 tree gfc_int4_type_node;
766 gfc_init_se (&lse, se);
767 gfc_conv_expr_val (&lse, expr->value.op.op1);
768 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
769 gfc_add_block_to_block (&se->pre, &lse.pre);
771 gfc_init_se (&rse, se);
772 gfc_conv_expr_val (&rse, expr->value.op.op2);
773 gfc_add_block_to_block (&se->pre, &rse.pre);
775 if (expr->value.op.op2->ts.type == BT_INTEGER
776 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
777 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
780 gfc_int4_type_node = gfc_get_int_type (4);
782 kind = expr->value.op.op1->ts.kind;
783 switch (expr->value.op.op2->ts.type)
786 ikind = expr->value.op.op2->ts.kind;
791 rse.expr = convert (gfc_int4_type_node, rse.expr);
813 if (expr->value.op.op1->ts.type == BT_INTEGER)
814 lse.expr = convert (gfc_int4_type_node, lse.expr);
839 switch (expr->value.op.op1->ts.type)
842 if (kind == 3) /* Case 16 was not handled properly above. */
844 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
848 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
852 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
864 fndecl = built_in_decls[BUILT_IN_POWF];
867 fndecl = built_in_decls[BUILT_IN_POW];
871 fndecl = built_in_decls[BUILT_IN_POWL];
882 fndecl = gfor_fndecl_math_cpowf;
885 fndecl = gfor_fndecl_math_cpow;
888 fndecl = gfor_fndecl_math_cpowl10;
891 fndecl = gfor_fndecl_math_cpowl16;
903 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
907 /* Generate code to allocate a string temporary. */
910 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
915 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
917 if (gfc_can_put_var_on_stack (len))
919 /* Create a temporary variable to hold the result. */
920 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
921 build_int_cst (gfc_charlen_type_node, 1));
922 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
923 tmp = build_array_type (gfc_character1_type_node, tmp);
924 var = gfc_create_var (tmp, "str");
925 var = gfc_build_addr_expr (type, var);
929 /* Allocate a temporary to hold the result. */
930 var = gfc_create_var (type, "pstr");
931 tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, len);
932 tmp = convert (type, tmp);
933 gfc_add_modify_expr (&se->pre, var, tmp);
935 /* Free the temporary afterwards. */
936 tmp = convert (pvoid_type_node, var);
937 tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
938 gfc_add_expr_to_block (&se->post, tmp);
945 /* Handle a string concatenation operation. A temporary will be allocated to
949 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
958 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
959 && expr->value.op.op2->ts.type == BT_CHARACTER);
961 gfc_init_se (&lse, se);
962 gfc_conv_expr (&lse, expr->value.op.op1);
963 gfc_conv_string_parameter (&lse);
964 gfc_init_se (&rse, se);
965 gfc_conv_expr (&rse, expr->value.op.op2);
966 gfc_conv_string_parameter (&rse);
968 gfc_add_block_to_block (&se->pre, &lse.pre);
969 gfc_add_block_to_block (&se->pre, &rse.pre);
971 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
972 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
973 if (len == NULL_TREE)
975 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
976 lse.string_length, rse.string_length);
979 type = build_pointer_type (type);
981 var = gfc_conv_string_tmp (se, type, len);
983 /* Do the actual concatenation. */
984 tmp = build_call_expr (gfor_fndecl_concat_string, 6,
986 lse.string_length, lse.expr,
987 rse.string_length, rse.expr);
988 gfc_add_expr_to_block (&se->pre, tmp);
990 /* Add the cleanup for the operands. */
991 gfc_add_block_to_block (&se->pre, &rse.post);
992 gfc_add_block_to_block (&se->pre, &lse.post);
995 se->string_length = len;
998 /* Translates an op expression. Common (binary) cases are handled by this
999 function, others are passed on. Recursion is used in either case.
1000 We use the fact that (op1.ts == op2.ts) (except for the power
1002 Operators need no special handling for scalarized expressions as long as
1003 they call gfc_conv_simple_val to get their operands.
1004 Character strings get special handling. */
1007 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1009 enum tree_code code;
1019 switch (expr->value.op.operator)
1021 case INTRINSIC_UPLUS:
1022 case INTRINSIC_PARENTHESES:
1023 gfc_conv_expr (se, expr->value.op.op1);
1026 case INTRINSIC_UMINUS:
1027 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1031 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1034 case INTRINSIC_PLUS:
1038 case INTRINSIC_MINUS:
1042 case INTRINSIC_TIMES:
1046 case INTRINSIC_DIVIDE:
1047 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1048 an integer, we must round towards zero, so we use a
1050 if (expr->ts.type == BT_INTEGER)
1051 code = TRUNC_DIV_EXPR;
1056 case INTRINSIC_POWER:
1057 gfc_conv_power_op (se, expr);
1060 case INTRINSIC_CONCAT:
1061 gfc_conv_concat_op (se, expr);
1065 code = TRUTH_ANDIF_EXPR;
1070 code = TRUTH_ORIF_EXPR;
1074 /* EQV and NEQV only work on logicals, but since we represent them
1075 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1084 case INTRINSIC_NEQV:
1114 case INTRINSIC_USER:
1115 case INTRINSIC_ASSIGN:
1116 /* These should be converted into function calls by the frontend. */
1120 fatal_error ("Unknown intrinsic op");
1124 /* The only exception to this is **, which is handled separately anyway. */
1125 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1127 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1131 gfc_init_se (&lse, se);
1132 gfc_conv_expr (&lse, expr->value.op.op1);
1133 gfc_add_block_to_block (&se->pre, &lse.pre);
1136 gfc_init_se (&rse, se);
1137 gfc_conv_expr (&rse, expr->value.op.op2);
1138 gfc_add_block_to_block (&se->pre, &rse.pre);
1142 gfc_conv_string_parameter (&lse);
1143 gfc_conv_string_parameter (&rse);
1145 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1146 rse.string_length, rse.expr);
1147 rse.expr = integer_zero_node;
1148 gfc_add_block_to_block (&lse.post, &rse.post);
1151 type = gfc_typenode_for_spec (&expr->ts);
1155 /* The result of logical ops is always boolean_type_node. */
1156 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1157 se->expr = convert (type, tmp);
1160 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1162 /* Add the post blocks. */
1163 gfc_add_block_to_block (&se->post, &rse.post);
1164 gfc_add_block_to_block (&se->post, &lse.post);
1167 /* If a string's length is one, we convert it to a single character. */
1170 gfc_to_single_character (tree len, tree str)
1172 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1174 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1175 && TREE_INT_CST_HIGH (len) == 0)
1177 str = fold_convert (pchar_type_node, str);
1178 return build_fold_indirect_ref (str);
1184 /* Compare two strings. If they are all single characters, the result is the
1185 subtraction of them. Otherwise, we build a library call. */
1188 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1195 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1196 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1198 type = gfc_get_int_type (gfc_default_integer_kind);
1200 sc1 = gfc_to_single_character (len1, str1);
1201 sc2 = gfc_to_single_character (len2, str2);
1203 /* Deal with single character specially. */
1204 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1206 sc1 = fold_convert (type, sc1);
1207 sc2 = fold_convert (type, sc2);
1208 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1211 /* Build a call for the comparison. */
1212 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1213 len1, str1, len2, str2);
1218 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1222 if (sym->attr.dummy)
1224 tmp = gfc_get_symbol_decl (sym);
1225 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1226 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1230 if (!sym->backend_decl)
1231 sym->backend_decl = gfc_get_extern_function_decl (sym);
1233 tmp = sym->backend_decl;
1234 if (sym->attr.cray_pointee)
1235 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1236 gfc_get_symbol_decl (sym->cp_pointer));
1237 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1239 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1240 tmp = build_fold_addr_expr (tmp);
1247 /* Translate the call for an elemental subroutine call used in an operator
1248 assignment. This is a simplified version of gfc_conv_function_call. */
1251 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1258 /* Only elemental subroutines with two arguments. */
1259 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1260 gcc_assert (sym->formal->next->next == NULL);
1262 gfc_init_block (&block);
1264 gfc_add_block_to_block (&block, &lse->pre);
1265 gfc_add_block_to_block (&block, &rse->pre);
1267 /* Build the argument list for the call, including hidden string lengths. */
1268 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1269 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1270 if (lse->string_length != NULL_TREE)
1271 args = gfc_chainon_list (args, lse->string_length);
1272 if (rse->string_length != NULL_TREE)
1273 args = gfc_chainon_list (args, rse->string_length);
1275 /* Build the function call. */
1276 gfc_init_se (&se, NULL);
1277 gfc_conv_function_val (&se, sym);
1278 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1279 tmp = build_call_list (tmp, se.expr, args);
1280 gfc_add_expr_to_block (&block, tmp);
1282 gfc_add_block_to_block (&block, &lse->post);
1283 gfc_add_block_to_block (&block, &rse->post);
1285 return gfc_finish_block (&block);
1289 /* Initialize MAPPING. */
1292 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1294 mapping->syms = NULL;
1295 mapping->charlens = NULL;
1299 /* Free all memory held by MAPPING (but not MAPPING itself). */
1302 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1304 gfc_interface_sym_mapping *sym;
1305 gfc_interface_sym_mapping *nextsym;
1307 gfc_charlen *nextcl;
1309 for (sym = mapping->syms; sym; sym = nextsym)
1311 nextsym = sym->next;
1312 gfc_free_symbol (sym->new->n.sym);
1313 gfc_free (sym->new);
1316 for (cl = mapping->charlens; cl; cl = nextcl)
1319 gfc_free_expr (cl->length);
1325 /* Return a copy of gfc_charlen CL. Add the returned structure to
1326 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1328 static gfc_charlen *
1329 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1334 new = gfc_get_charlen ();
1335 new->next = mapping->charlens;
1336 new->length = gfc_copy_expr (cl->length);
1338 mapping->charlens = new;
1343 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1344 array variable that can be used as the actual argument for dummy
1345 argument SYM. Add any initialization code to BLOCK. PACKED is as
1346 for gfc_get_nodesc_array_type and DATA points to the first element
1347 in the passed array. */
1350 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1351 int packed, tree data)
1356 type = gfc_typenode_for_spec (&sym->ts);
1357 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1359 var = gfc_create_var (type, "ifm");
1360 gfc_add_modify_expr (block, var, fold_convert (type, data));
1366 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1367 and offset of descriptorless array type TYPE given that it has the same
1368 size as DESC. Add any set-up code to BLOCK. */
1371 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1378 offset = gfc_index_zero_node;
1379 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1381 dim = gfc_rank_cst[n];
1382 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1383 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1385 GFC_TYPE_ARRAY_LBOUND (type, n)
1386 = gfc_conv_descriptor_lbound (desc, dim);
1387 GFC_TYPE_ARRAY_UBOUND (type, n)
1388 = gfc_conv_descriptor_ubound (desc, dim);
1390 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1392 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1393 gfc_conv_descriptor_ubound (desc, dim),
1394 gfc_conv_descriptor_lbound (desc, dim));
1395 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1396 GFC_TYPE_ARRAY_LBOUND (type, n),
1398 tmp = gfc_evaluate_now (tmp, block);
1399 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1401 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1402 GFC_TYPE_ARRAY_LBOUND (type, n),
1403 GFC_TYPE_ARRAY_STRIDE (type, n));
1404 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1406 offset = gfc_evaluate_now (offset, block);
1407 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1411 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1412 in SE. The caller may still use se->expr and se->string_length after
1413 calling this function. */
1416 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1417 gfc_symbol * sym, gfc_se * se)
1419 gfc_interface_sym_mapping *sm;
1423 gfc_symbol *new_sym;
1425 gfc_symtree *new_symtree;
1427 /* Create a new symbol to represent the actual argument. */
1428 new_sym = gfc_new_symbol (sym->name, NULL);
1429 new_sym->ts = sym->ts;
1430 new_sym->attr.referenced = 1;
1431 new_sym->attr.dimension = sym->attr.dimension;
1432 new_sym->attr.pointer = sym->attr.pointer;
1433 new_sym->attr.allocatable = sym->attr.allocatable;
1434 new_sym->attr.flavor = sym->attr.flavor;
1436 /* Create a fake symtree for it. */
1438 new_symtree = gfc_new_symtree (&root, sym->name);
1439 new_symtree->n.sym = new_sym;
1440 gcc_assert (new_symtree == root);
1442 /* Create a dummy->actual mapping. */
1443 sm = gfc_getmem (sizeof (*sm));
1444 sm->next = mapping->syms;
1446 sm->new = new_symtree;
1449 /* Stabilize the argument's value. */
1450 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1452 if (sym->ts.type == BT_CHARACTER)
1454 /* Create a copy of the dummy argument's length. */
1455 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1457 /* If the length is specified as "*", record the length that
1458 the caller is passing. We should use the callee's length
1459 in all other cases. */
1460 if (!new_sym->ts.cl->length)
1462 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1463 new_sym->ts.cl->backend_decl = se->string_length;
1467 /* Use the passed value as-is if the argument is a function. */
1468 if (sym->attr.flavor == FL_PROCEDURE)
1471 /* If the argument is either a string or a pointer to a string,
1472 convert it to a boundless character type. */
1473 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1475 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1476 tmp = build_pointer_type (tmp);
1477 if (sym->attr.pointer)
1478 value = build_fold_indirect_ref (se->expr);
1481 value = fold_convert (tmp, value);
1484 /* If the argument is a scalar, a pointer to an array or an allocatable,
1486 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1487 value = build_fold_indirect_ref (se->expr);
1489 /* For character(*), use the actual argument's descriptor. */
1490 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1491 value = build_fold_indirect_ref (se->expr);
1493 /* If the argument is an array descriptor, use it to determine
1494 information about the actual argument's shape. */
1495 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1496 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1498 /* Get the actual argument's descriptor. */
1499 desc = build_fold_indirect_ref (se->expr);
1501 /* Create the replacement variable. */
1502 tmp = gfc_conv_descriptor_data_get (desc);
1503 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1505 /* Use DESC to work out the upper bounds, strides and offset. */
1506 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1509 /* Otherwise we have a packed array. */
1510 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1512 new_sym->backend_decl = value;
1516 /* Called once all dummy argument mappings have been added to MAPPING,
1517 but before the mapping is used to evaluate expressions. Pre-evaluate
1518 the length of each argument, adding any initialization code to PRE and
1519 any finalization code to POST. */
1522 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1523 stmtblock_t * pre, stmtblock_t * post)
1525 gfc_interface_sym_mapping *sym;
1529 for (sym = mapping->syms; sym; sym = sym->next)
1530 if (sym->new->n.sym->ts.type == BT_CHARACTER
1531 && !sym->new->n.sym->ts.cl->backend_decl)
1533 expr = sym->new->n.sym->ts.cl->length;
1534 gfc_apply_interface_mapping_to_expr (mapping, expr);
1535 gfc_init_se (&se, NULL);
1536 gfc_conv_expr (&se, expr);
1538 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1539 gfc_add_block_to_block (pre, &se.pre);
1540 gfc_add_block_to_block (post, &se.post);
1542 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1547 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1551 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1552 gfc_constructor * c)
1554 for (; c; c = c->next)
1556 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1559 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1560 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1561 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1567 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1571 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1576 for (; ref; ref = ref->next)
1580 for (n = 0; n < ref->u.ar.dimen; n++)
1582 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1583 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1584 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1586 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1593 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1594 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1600 /* EXPR is a copy of an expression that appeared in the interface
1601 associated with MAPPING. Walk it recursively looking for references to
1602 dummy arguments that MAPPING maps to actual arguments. Replace each such
1603 reference with a reference to the associated actual argument. */
1606 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1609 gfc_interface_sym_mapping *sym;
1610 gfc_actual_arglist *actual;
1611 int seen_result = 0;
1616 /* Copying an expression does not copy its length, so do that here. */
1617 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1619 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1620 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1623 /* Apply the mapping to any references. */
1624 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1626 /* ...and to the expression's symbol, if it has one. */
1628 for (sym = mapping->syms; sym; sym = sym->next)
1629 if (sym->old == expr->symtree->n.sym)
1630 expr->symtree = sym->new;
1632 /* ...and to subexpressions in expr->value. */
1633 switch (expr->expr_type)
1636 if (expr->symtree->n.sym->attr.result)
1640 case EXPR_SUBSTRING:
1644 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1645 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1649 if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1650 && gfc_apply_interface_mapping_to_expr (mapping,
1651 expr->value.function.actual->expr)
1652 && expr->value.function.esym == NULL
1653 && expr->value.function.isym != NULL
1654 && expr->value.function.isym->generic_id == GFC_ISYM_LEN)
1657 new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1659 gfc_free (new_expr);
1660 gfc_apply_interface_mapping_to_expr (mapping, expr);
1664 for (sym = mapping->syms; sym; sym = sym->next)
1665 if (sym->old == expr->value.function.esym)
1666 expr->value.function.esym = sym->new->n.sym;
1668 for (actual = expr->value.function.actual; actual; actual = actual->next)
1669 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1673 case EXPR_STRUCTURE:
1674 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1681 /* Evaluate interface expression EXPR using MAPPING. Store the result
1685 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1686 gfc_se * se, gfc_expr * expr)
1688 expr = gfc_copy_expr (expr);
1689 gfc_apply_interface_mapping_to_expr (mapping, expr);
1690 gfc_conv_expr (se, expr);
1691 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1692 gfc_free_expr (expr);
1695 /* Returns a reference to a temporary array into which a component of
1696 an actual argument derived type array is copied and then returned
1697 after the function call.
1698 TODO Get rid of this kludge, when array descriptors are capable of
1699 handling arrays with a bigger stride in bytes than size. */
1702 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1703 int g77, sym_intent intent)
1719 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1721 gfc_init_se (&lse, NULL);
1722 gfc_init_se (&rse, NULL);
1724 /* Walk the argument expression. */
1725 rss = gfc_walk_expr (expr);
1727 gcc_assert (rss != gfc_ss_terminator);
1729 /* Initialize the scalarizer. */
1730 gfc_init_loopinfo (&loop);
1731 gfc_add_ss_to_loop (&loop, rss);
1733 /* Calculate the bounds of the scalarization. */
1734 gfc_conv_ss_startstride (&loop);
1736 /* Build an ss for the temporary. */
1737 base_type = gfc_typenode_for_spec (&expr->ts);
1738 if (GFC_ARRAY_TYPE_P (base_type)
1739 || GFC_DESCRIPTOR_TYPE_P (base_type))
1740 base_type = gfc_get_element_type (base_type);
1742 loop.temp_ss = gfc_get_ss ();;
1743 loop.temp_ss->type = GFC_SS_TEMP;
1744 loop.temp_ss->data.temp.type = base_type;
1746 if (expr->ts.type == BT_CHARACTER)
1748 gfc_ref *char_ref = expr->ref;
1750 for (; char_ref; char_ref = char_ref->next)
1751 if (char_ref->type == REF_SUBSTRING)
1755 expr->ts.cl = gfc_get_charlen ();
1756 expr->ts.cl->next = char_ref->u.ss.length->next;
1757 char_ref->u.ss.length->next = expr->ts.cl;
1759 gfc_init_se (&tmp_se, NULL);
1760 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1761 gfc_array_index_type);
1762 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1763 tmp_se.expr, gfc_index_one_node);
1764 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1765 gfc_init_se (&tmp_se, NULL);
1766 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1767 gfc_array_index_type);
1768 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1770 expr->ts.cl->backend_decl = tmp;
1774 loop.temp_ss->data.temp.type
1775 = gfc_typenode_for_spec (&expr->ts);
1776 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1779 loop.temp_ss->data.temp.dimen = loop.dimen;
1780 loop.temp_ss->next = gfc_ss_terminator;
1782 /* Associate the SS with the loop. */
1783 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1785 /* Setup the scalarizing loops. */
1786 gfc_conv_loop_setup (&loop);
1788 /* Pass the temporary descriptor back to the caller. */
1789 info = &loop.temp_ss->data.info;
1790 parmse->expr = info->descriptor;
1792 /* Setup the gfc_se structures. */
1793 gfc_copy_loopinfo_to_se (&lse, &loop);
1794 gfc_copy_loopinfo_to_se (&rse, &loop);
1797 lse.ss = loop.temp_ss;
1798 gfc_mark_ss_chain_used (rss, 1);
1799 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1801 /* Start the scalarized loop body. */
1802 gfc_start_scalarized_body (&loop, &body);
1804 /* Translate the expression. */
1805 gfc_conv_expr (&rse, expr);
1807 gfc_conv_tmp_array_ref (&lse);
1808 gfc_advance_se_ss_chain (&lse);
1810 if (intent != INTENT_OUT)
1812 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1813 gfc_add_expr_to_block (&body, tmp);
1814 gcc_assert (rse.ss == gfc_ss_terminator);
1815 gfc_trans_scalarizing_loops (&loop, &body);
1819 /* Make sure that the temporary declaration survives by merging
1820 all the loop declarations into the current context. */
1821 for (n = 0; n < loop.dimen; n++)
1823 gfc_merge_block_scope (&body);
1824 body = loop.code[loop.order[n]];
1826 gfc_merge_block_scope (&body);
1829 /* Add the post block after the second loop, so that any
1830 freeing of allocated memory is done at the right time. */
1831 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1833 /**********Copy the temporary back again.*********/
1835 gfc_init_se (&lse, NULL);
1836 gfc_init_se (&rse, NULL);
1838 /* Walk the argument expression. */
1839 lss = gfc_walk_expr (expr);
1840 rse.ss = loop.temp_ss;
1843 /* Initialize the scalarizer. */
1844 gfc_init_loopinfo (&loop2);
1845 gfc_add_ss_to_loop (&loop2, lss);
1847 /* Calculate the bounds of the scalarization. */
1848 gfc_conv_ss_startstride (&loop2);
1850 /* Setup the scalarizing loops. */
1851 gfc_conv_loop_setup (&loop2);
1853 gfc_copy_loopinfo_to_se (&lse, &loop2);
1854 gfc_copy_loopinfo_to_se (&rse, &loop2);
1856 gfc_mark_ss_chain_used (lss, 1);
1857 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1859 /* Declare the variable to hold the temporary offset and start the
1860 scalarized loop body. */
1861 offset = gfc_create_var (gfc_array_index_type, NULL);
1862 gfc_start_scalarized_body (&loop2, &body);
1864 /* Build the offsets for the temporary from the loop variables. The
1865 temporary array has lbounds of zero and strides of one in all
1866 dimensions, so this is very simple. The offset is only computed
1867 outside the innermost loop, so the overall transfer could be
1868 optimized further. */
1869 info = &rse.ss->data.info;
1871 tmp_index = gfc_index_zero_node;
1872 for (n = info->dimen - 1; n > 0; n--)
1875 tmp = rse.loop->loopvar[n];
1876 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1877 tmp, rse.loop->from[n]);
1878 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1881 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1882 rse.loop->to[n-1], rse.loop->from[n-1]);
1883 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1884 tmp_str, gfc_index_one_node);
1886 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1890 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1891 tmp_index, rse.loop->from[0]);
1892 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1894 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1895 rse.loop->loopvar[0], offset);
1897 /* Now use the offset for the reference. */
1898 tmp = build_fold_indirect_ref (info->data);
1899 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1901 if (expr->ts.type == BT_CHARACTER)
1902 rse.string_length = expr->ts.cl->backend_decl;
1904 gfc_conv_expr (&lse, expr);
1906 gcc_assert (lse.ss == gfc_ss_terminator);
1908 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1909 gfc_add_expr_to_block (&body, tmp);
1911 /* Generate the copying loops. */
1912 gfc_trans_scalarizing_loops (&loop2, &body);
1914 /* Wrap the whole thing up by adding the second loop to the post-block
1915 and following it by the post-block of the first loop. In this way,
1916 if the temporary needs freeing, it is done after use! */
1917 if (intent != INTENT_IN)
1919 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1920 gfc_add_block_to_block (&parmse->post, &loop2.post);
1923 gfc_add_block_to_block (&parmse->post, &loop.post);
1925 gfc_cleanup_loop (&loop);
1926 gfc_cleanup_loop (&loop2);
1928 /* Pass the string length to the argument expression. */
1929 if (expr->ts.type == BT_CHARACTER)
1930 parmse->string_length = expr->ts.cl->backend_decl;
1932 /* We want either the address for the data or the address of the descriptor,
1933 depending on the mode of passing array arguments. */
1935 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1937 parmse->expr = build_fold_addr_expr (parmse->expr);
1942 /* Is true if an array reference is followed by a component or substring
1946 is_aliased_array (gfc_expr * e)
1952 for (ref = e->ref; ref; ref = ref->next)
1954 if (ref->type == REF_ARRAY
1955 && ref->u.ar.type != AR_ELEMENT)
1959 && ref->type != REF_ARRAY)
1965 /* Generate the code for argument list functions. */
1968 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
1970 /* Pass by value for g77 %VAL(arg), pass the address
1971 indirectly for %LOC, else by reference. Thus %REF
1972 is a "do-nothing" and %LOC is the same as an F95
1974 if (strncmp (name, "%VAL", 4) == 0)
1975 gfc_conv_expr (se, expr);
1976 else if (strncmp (name, "%LOC", 4) == 0)
1978 gfc_conv_expr_reference (se, expr);
1979 se->expr = gfc_build_addr_expr (NULL, se->expr);
1981 else if (strncmp (name, "%REF", 4) == 0)
1982 gfc_conv_expr_reference (se, expr);
1984 gfc_error ("Unknown argument list function at %L", &expr->where);
1988 /* Generate code for a procedure call. Note can return se->post != NULL.
1989 If se->direct_byref is set then se->expr contains the return parameter.
1990 Return nonzero, if the call has alternate specifiers. */
1993 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1994 gfc_actual_arglist * arg, tree append_args)
1996 gfc_interface_mapping mapping;
2010 gfc_formal_arglist *formal;
2011 int has_alternate_specifier = 0;
2012 bool need_interface_mapping;
2019 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2021 arglist = NULL_TREE;
2022 retargs = NULL_TREE;
2023 stringargs = NULL_TREE;
2029 if (!sym->attr.elemental)
2031 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2032 if (se->ss->useflags)
2034 gcc_assert (gfc_return_by_reference (sym)
2035 && sym->result->attr.dimension);
2036 gcc_assert (se->loop != NULL);
2038 /* Access the previously obtained result. */
2039 gfc_conv_tmp_array_ref (se);
2040 gfc_advance_se_ss_chain (se);
2044 info = &se->ss->data.info;
2049 gfc_init_block (&post);
2050 gfc_init_interface_mapping (&mapping);
2051 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2052 && sym->ts.cl->length
2053 && sym->ts.cl->length->expr_type
2055 || sym->attr.dimension);
2056 formal = sym->formal;
2057 /* Evaluate the arguments. */
2058 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2061 fsym = formal ? formal->sym : NULL;
2062 parm_kind = MISSING;
2066 if (se->ignore_optional)
2068 /* Some intrinsics have already been resolved to the correct
2072 else if (arg->label)
2074 has_alternate_specifier = 1;
2079 /* Pass a NULL pointer for an absent arg. */
2080 gfc_init_se (&parmse, NULL);
2081 parmse.expr = null_pointer_node;
2082 if (arg->missing_arg_type == BT_CHARACTER)
2083 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2086 else if (se->ss && se->ss->useflags)
2088 /* An elemental function inside a scalarized loop. */
2089 gfc_init_se (&parmse, se);
2090 gfc_conv_expr_reference (&parmse, e);
2091 parm_kind = ELEMENTAL;
2095 /* A scalar or transformational function. */
2096 gfc_init_se (&parmse, NULL);
2097 argss = gfc_walk_expr (e);
2099 if (argss == gfc_ss_terminator)
2102 if (fsym && fsym->attr.value)
2104 gfc_conv_expr (&parmse, e);
2106 else if (arg->name && arg->name[0] == '%')
2107 /* Argument list functions %VAL, %LOC and %REF are signalled
2108 through arg->name. */
2109 conv_arglist_function (&parmse, arg->expr, arg->name);
2110 else if ((e->expr_type == EXPR_FUNCTION)
2111 && e->symtree->n.sym->attr.pointer
2112 && fsym && fsym->attr.target)
2114 gfc_conv_expr (&parmse, e);
2115 parmse.expr = build_fold_addr_expr (parmse.expr);
2119 gfc_conv_expr_reference (&parmse, e);
2120 if (fsym && fsym->attr.pointer
2121 && fsym->attr.flavor != FL_PROCEDURE
2122 && e->expr_type != EXPR_NULL)
2124 /* Scalar pointer dummy args require an extra level of
2125 indirection. The null pointer already contains
2126 this level of indirection. */
2127 parm_kind = SCALAR_POINTER;
2128 parmse.expr = build_fold_addr_expr (parmse.expr);
2134 /* If the procedure requires an explicit interface, the actual
2135 argument is passed according to the corresponding formal
2136 argument. If the corresponding formal argument is a POINTER,
2137 ALLOCATABLE or assumed shape, we do not use g77's calling
2138 convention, and pass the address of the array descriptor
2139 instead. Otherwise we use g77's calling convention. */
2142 && !(fsym->attr.pointer || fsym->attr.allocatable)
2143 && fsym->as->type != AS_ASSUMED_SHAPE;
2144 f = f || !sym->attr.always_explicit;
2146 if (e->expr_type == EXPR_VARIABLE
2147 && is_aliased_array (e))
2148 /* The actual argument is a component reference to an
2149 array of derived types. In this case, the argument
2150 is converted to a temporary, which is passed and then
2151 written back after the procedure call. */
2152 gfc_conv_aliased_arg (&parmse, e, f,
2153 fsym ? fsym->attr.intent : INTENT_INOUT);
2155 gfc_conv_array_parameter (&parmse, e, argss, f);
2157 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2158 allocated on entry, it must be deallocated. */
2159 if (fsym && fsym->attr.allocatable
2160 && fsym->attr.intent == INTENT_OUT)
2162 tmp = build_fold_indirect_ref (parmse.expr);
2163 tmp = gfc_trans_dealloc_allocated (tmp);
2164 gfc_add_expr_to_block (&se->pre, tmp);
2174 /* If an optional argument is itself an optional dummy
2175 argument, check its presence and substitute a null
2177 if (e->expr_type == EXPR_VARIABLE
2178 && e->symtree->n.sym->attr.optional
2179 && fsym->attr.optional)
2180 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2182 /* If an INTENT(OUT) dummy of derived type has a default
2183 initializer, it must be (re)initialized here. */
2184 if (fsym->attr.intent == INTENT_OUT
2185 && fsym->ts.type == BT_DERIVED
2188 gcc_assert (!fsym->attr.allocatable);
2189 tmp = gfc_trans_assignment (e, fsym->value, false);
2190 gfc_add_expr_to_block (&se->pre, tmp);
2193 /* Obtain the character length of an assumed character
2194 length procedure from the typespec. */
2195 if (fsym->ts.type == BT_CHARACTER
2196 && parmse.string_length == NULL_TREE
2197 && e->ts.type == BT_PROCEDURE
2198 && e->symtree->n.sym->ts.type == BT_CHARACTER
2199 && e->symtree->n.sym->ts.cl->length != NULL)
2201 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2202 parmse.string_length
2203 = e->symtree->n.sym->ts.cl->backend_decl;
2207 if (need_interface_mapping)
2208 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2211 gfc_add_block_to_block (&se->pre, &parmse.pre);
2212 gfc_add_block_to_block (&post, &parmse.post);
2214 /* Allocated allocatable components of derived types must be
2215 deallocated for INTENT(OUT) dummy arguments and non-variable
2216 scalars. Non-variable arrays are dealt with in trans-array.c
2217 (gfc_conv_array_parameter). */
2218 if (e && e->ts.type == BT_DERIVED
2219 && e->ts.derived->attr.alloc_comp
2220 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2222 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2225 tmp = build_fold_indirect_ref (parmse.expr);
2226 parm_rank = e->rank;
2234 case (SCALAR_POINTER):
2235 tmp = build_fold_indirect_ref (tmp);
2242 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2243 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2244 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2245 tmp, build_empty_stmt ());
2247 if (e->expr_type != EXPR_VARIABLE)
2248 /* Don't deallocate non-variables until they have been used. */
2249 gfc_add_expr_to_block (&se->post, tmp);
2252 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2253 gfc_add_expr_to_block (&se->pre, tmp);
2257 /* Character strings are passed as two parameters, a length and a
2259 if (parmse.string_length != NULL_TREE)
2260 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2262 arglist = gfc_chainon_list (arglist, parmse.expr);
2264 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2267 if (ts.type == BT_CHARACTER)
2269 if (sym->ts.cl->length == NULL)
2271 /* Assumed character length results are not allowed by 5.1.1.5 of the
2272 standard and are trapped in resolve.c; except in the case of SPREAD
2273 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2274 we take the character length of the first argument for the result.
2275 For dummies, we have to look through the formal argument list for
2276 this function and use the character length found there.*/
2277 if (!sym->attr.dummy)
2278 cl.backend_decl = TREE_VALUE (stringargs);
2281 formal = sym->ns->proc_name->formal;
2282 for (; formal; formal = formal->next)
2283 if (strcmp (formal->sym->name, sym->name) == 0)
2284 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2291 /* Calculate the length of the returned string. */
2292 gfc_init_se (&parmse, NULL);
2293 if (need_interface_mapping)
2294 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2296 gfc_conv_expr (&parmse, sym->ts.cl->length);
2297 gfc_add_block_to_block (&se->pre, &parmse.pre);
2298 gfc_add_block_to_block (&se->post, &parmse.post);
2300 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2301 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2302 build_int_cst (gfc_charlen_type_node, 0));
2303 cl.backend_decl = tmp;
2306 /* Set up a charlen structure for it. */
2311 len = cl.backend_decl;
2314 byref = gfc_return_by_reference (sym);
2317 if (se->direct_byref)
2318 retargs = gfc_chainon_list (retargs, se->expr);
2319 else if (sym->result->attr.dimension)
2321 gcc_assert (se->loop && info);
2323 /* Set the type of the array. */
2324 tmp = gfc_typenode_for_spec (&ts);
2325 info->dimen = se->loop->dimen;
2327 /* Evaluate the bounds of the result, if known. */
2328 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2330 /* Create a temporary to store the result. In case the function
2331 returns a pointer, the temporary will be a shallow copy and
2332 mustn't be deallocated. */
2333 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2334 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2335 false, !sym->attr.pointer, callee_alloc);
2337 /* Pass the temporary as the first argument. */
2338 tmp = info->descriptor;
2339 tmp = build_fold_addr_expr (tmp);
2340 retargs = gfc_chainon_list (retargs, tmp);
2342 else if (ts.type == BT_CHARACTER)
2344 /* Pass the string length. */
2345 type = gfc_get_character_type (ts.kind, ts.cl);
2346 type = build_pointer_type (type);
2348 /* Return an address to a char[0:len-1]* temporary for
2349 character pointers. */
2350 if (sym->attr.pointer || sym->attr.allocatable)
2352 /* Build char[0:len-1] * pstr. */
2353 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2354 build_int_cst (gfc_charlen_type_node, 1));
2355 tmp = build_range_type (gfc_array_index_type,
2356 gfc_index_zero_node, tmp);
2357 tmp = build_array_type (gfc_character1_type_node, tmp);
2358 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2360 /* Provide an address expression for the function arguments. */
2361 var = build_fold_addr_expr (var);
2364 var = gfc_conv_string_tmp (se, type, len);
2366 retargs = gfc_chainon_list (retargs, var);
2370 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2372 type = gfc_get_complex_type (ts.kind);
2373 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2374 retargs = gfc_chainon_list (retargs, var);
2377 /* Add the string length to the argument list. */
2378 if (ts.type == BT_CHARACTER)
2379 retargs = gfc_chainon_list (retargs, len);
2381 gfc_free_interface_mapping (&mapping);
2383 /* Add the return arguments. */
2384 arglist = chainon (retargs, arglist);
2386 /* Add the hidden string length parameters to the arguments. */
2387 arglist = chainon (arglist, stringargs);
2389 /* We may want to append extra arguments here. This is used e.g. for
2390 calls to libgfortran_matmul_??, which need extra information. */
2391 if (append_args != NULL_TREE)
2392 arglist = chainon (arglist, append_args);
2394 /* Generate the actual call. */
2395 gfc_conv_function_val (se, sym);
2397 /* If there are alternate return labels, function type should be
2398 integer. Can't modify the type in place though, since it can be shared
2399 with other functions. For dummy arguments, the typing is done to
2400 to this result, even if it has to be repeated for each call. */
2401 if (has_alternate_specifier
2402 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2404 if (!sym->attr.dummy)
2406 TREE_TYPE (sym->backend_decl)
2407 = build_function_type (integer_type_node,
2408 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2409 se->expr = build_fold_addr_expr (sym->backend_decl);
2412 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2415 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2416 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2418 /* If we have a pointer function, but we don't want a pointer, e.g.
2421 where f is pointer valued, we have to dereference the result. */
2422 if (!se->want_pointer && !byref && sym->attr.pointer)
2423 se->expr = build_fold_indirect_ref (se->expr);
2425 /* f2c calling conventions require a scalar default real function to
2426 return a double precision result. Convert this back to default
2427 real. We only care about the cases that can happen in Fortran 77.
2429 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2430 && sym->ts.kind == gfc_default_real_kind
2431 && !sym->attr.always_explicit)
2432 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2434 /* A pure function may still have side-effects - it may modify its
2436 TREE_SIDE_EFFECTS (se->expr) = 1;
2438 if (!sym->attr.pure)
2439 TREE_SIDE_EFFECTS (se->expr) = 1;
2444 /* Add the function call to the pre chain. There is no expression. */
2445 gfc_add_expr_to_block (&se->pre, se->expr);
2446 se->expr = NULL_TREE;
2448 if (!se->direct_byref)
2450 if (sym->attr.dimension)
2452 if (flag_bounds_check)
2454 /* Check the data pointer hasn't been modified. This would
2455 happen in a function returning a pointer. */
2456 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2457 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2459 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2461 se->expr = info->descriptor;
2462 /* Bundle in the string length. */
2463 se->string_length = len;
2465 else if (sym->ts.type == BT_CHARACTER)
2467 /* Dereference for character pointer results. */
2468 if (sym->attr.pointer || sym->attr.allocatable)
2469 se->expr = build_fold_indirect_ref (var);
2473 se->string_length = len;
2477 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2478 se->expr = build_fold_indirect_ref (var);
2483 /* Follow the function call with the argument post block. */
2485 gfc_add_block_to_block (&se->pre, &post);
2487 gfc_add_block_to_block (&se->post, &post);
2489 return has_alternate_specifier;
2493 /* Generate code to copy a string. */
2496 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2497 tree slength, tree src)
2499 tree tmp, dlen, slen;
2507 stmtblock_t tempblock;
2509 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2510 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2512 /* Deal with single character specially. */
2513 dsc = gfc_to_single_character (dlen, dest);
2514 ssc = gfc_to_single_character (slen, src);
2515 if (dsc != NULL_TREE && ssc != NULL_TREE)
2517 gfc_add_modify_expr (block, dsc, ssc);
2521 /* Do nothing if the destination length is zero. */
2522 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2523 build_int_cst (gfc_charlen_type_node, 0));
2525 /* The following code was previously in _gfortran_copy_string:
2527 // The two strings may overlap so we use memmove.
2529 copy_string (GFC_INTEGER_4 destlen, char * dest,
2530 GFC_INTEGER_4 srclen, const char * src)
2532 if (srclen >= destlen)
2534 // This will truncate if too long.
2535 memmove (dest, src, destlen);
2539 memmove (dest, src, srclen);
2541 memset (&dest[srclen], ' ', destlen - srclen);
2545 We're now doing it here for better optimization, but the logic
2548 /* Truncate string if source is too long. */
2549 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2550 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2551 3, dest, src, dlen);
2553 /* Else copy and pad with spaces. */
2554 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2555 3, dest, src, slen);
2557 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2558 fold_convert (pchar_type_node, slen));
2559 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2561 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2562 lang_hooks.to_target_charset (' ')),
2563 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2566 gfc_init_block (&tempblock);
2567 gfc_add_expr_to_block (&tempblock, tmp3);
2568 gfc_add_expr_to_block (&tempblock, tmp4);
2569 tmp3 = gfc_finish_block (&tempblock);
2571 /* The whole copy_string function is there. */
2572 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2573 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2574 gfc_add_expr_to_block (block, tmp);
2578 /* Translate a statement function.
2579 The value of a statement function reference is obtained by evaluating the
2580 expression using the values of the actual arguments for the values of the
2581 corresponding dummy arguments. */
2584 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2588 gfc_formal_arglist *fargs;
2589 gfc_actual_arglist *args;
2592 gfc_saved_var *saved_vars;
2598 sym = expr->symtree->n.sym;
2599 args = expr->value.function.actual;
2600 gfc_init_se (&lse, NULL);
2601 gfc_init_se (&rse, NULL);
2604 for (fargs = sym->formal; fargs; fargs = fargs->next)
2606 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2607 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2609 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2611 /* Each dummy shall be specified, explicitly or implicitly, to be
2613 gcc_assert (fargs->sym->attr.dimension == 0);
2616 /* Create a temporary to hold the value. */
2617 type = gfc_typenode_for_spec (&fsym->ts);
2618 temp_vars[n] = gfc_create_var (type, fsym->name);
2620 if (fsym->ts.type == BT_CHARACTER)
2622 /* Copy string arguments. */
2625 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2626 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2628 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2629 tmp = gfc_build_addr_expr (build_pointer_type (type),
2632 gfc_conv_expr (&rse, args->expr);
2633 gfc_conv_string_parameter (&rse);
2634 gfc_add_block_to_block (&se->pre, &lse.pre);
2635 gfc_add_block_to_block (&se->pre, &rse.pre);
2637 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2639 gfc_add_block_to_block (&se->pre, &lse.post);
2640 gfc_add_block_to_block (&se->pre, &rse.post);
2644 /* For everything else, just evaluate the expression. */
2645 gfc_conv_expr (&lse, args->expr);
2647 gfc_add_block_to_block (&se->pre, &lse.pre);
2648 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2649 gfc_add_block_to_block (&se->pre, &lse.post);
2655 /* Use the temporary variables in place of the real ones. */
2656 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2657 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2659 gfc_conv_expr (se, sym->value);
2661 if (sym->ts.type == BT_CHARACTER)
2663 gfc_conv_const_charlen (sym->ts.cl);
2665 /* Force the expression to the correct length. */
2666 if (!INTEGER_CST_P (se->string_length)
2667 || tree_int_cst_lt (se->string_length,
2668 sym->ts.cl->backend_decl))
2670 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2671 tmp = gfc_create_var (type, sym->name);
2672 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2673 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2674 se->string_length, se->expr);
2677 se->string_length = sym->ts.cl->backend_decl;
2680 /* Restore the original variables. */
2681 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2682 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2683 gfc_free (saved_vars);
2687 /* Translate a function expression. */
2690 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2694 if (expr->value.function.isym)
2696 gfc_conv_intrinsic_function (se, expr);
2700 /* We distinguish statement functions from general functions to improve
2701 runtime performance. */
2702 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2704 gfc_conv_statement_function (se, expr);
2708 /* expr.value.function.esym is the resolved (specific) function symbol for
2709 most functions. However this isn't set for dummy procedures. */
2710 sym = expr->value.function.esym;
2712 sym = expr->symtree->n.sym;
2713 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2718 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2720 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2721 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2723 gfc_conv_tmp_array_ref (se);
2724 gfc_advance_se_ss_chain (se);
2728 /* Build a static initializer. EXPR is the expression for the initial value.
2729 The other parameters describe the variable of the component being
2730 initialized. EXPR may be null. */
2733 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2734 bool array, bool pointer)
2738 if (!(expr || pointer))
2743 /* Arrays need special handling. */
2745 return gfc_build_null_descriptor (type);
2747 return gfc_conv_array_initializer (type, expr);
2750 return fold_convert (type, null_pointer_node);
2756 gfc_init_se (&se, NULL);
2757 gfc_conv_structure (&se, expr, 1);
2761 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2764 gfc_init_se (&se, NULL);
2765 gfc_conv_constant (&se, expr);
2772 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2784 gfc_start_block (&block);
2786 /* Initialize the scalarizer. */
2787 gfc_init_loopinfo (&loop);
2789 gfc_init_se (&lse, NULL);
2790 gfc_init_se (&rse, NULL);
2793 rss = gfc_walk_expr (expr);
2794 if (rss == gfc_ss_terminator)
2796 /* The rhs is scalar. Add a ss for the expression. */
2797 rss = gfc_get_ss ();
2798 rss->next = gfc_ss_terminator;
2799 rss->type = GFC_SS_SCALAR;
2803 /* Create a SS for the destination. */
2804 lss = gfc_get_ss ();
2805 lss->type = GFC_SS_COMPONENT;
2807 lss->shape = gfc_get_shape (cm->as->rank);
2808 lss->next = gfc_ss_terminator;
2809 lss->data.info.dimen = cm->as->rank;
2810 lss->data.info.descriptor = dest;
2811 lss->data.info.data = gfc_conv_array_data (dest);
2812 lss->data.info.offset = gfc_conv_array_offset (dest);
2813 for (n = 0; n < cm->as->rank; n++)
2815 lss->data.info.dim[n] = n;
2816 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2817 lss->data.info.stride[n] = gfc_index_one_node;
2819 mpz_init (lss->shape[n]);
2820 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2821 cm->as->lower[n]->value.integer);
2822 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2825 /* Associate the SS with the loop. */
2826 gfc_add_ss_to_loop (&loop, lss);
2827 gfc_add_ss_to_loop (&loop, rss);
2829 /* Calculate the bounds of the scalarization. */
2830 gfc_conv_ss_startstride (&loop);
2832 /* Setup the scalarizing loops. */
2833 gfc_conv_loop_setup (&loop);
2835 /* Setup the gfc_se structures. */
2836 gfc_copy_loopinfo_to_se (&lse, &loop);
2837 gfc_copy_loopinfo_to_se (&rse, &loop);
2840 gfc_mark_ss_chain_used (rss, 1);
2842 gfc_mark_ss_chain_used (lss, 1);
2844 /* Start the scalarized loop body. */
2845 gfc_start_scalarized_body (&loop, &body);
2847 gfc_conv_tmp_array_ref (&lse);
2848 if (cm->ts.type == BT_CHARACTER)
2849 lse.string_length = cm->ts.cl->backend_decl;
2851 gfc_conv_expr (&rse, expr);
2853 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2854 gfc_add_expr_to_block (&body, tmp);
2856 gcc_assert (rse.ss == gfc_ss_terminator);
2858 /* Generate the copying loops. */
2859 gfc_trans_scalarizing_loops (&loop, &body);
2861 /* Wrap the whole thing up. */
2862 gfc_add_block_to_block (&block, &loop.pre);
2863 gfc_add_block_to_block (&block, &loop.post);
2865 for (n = 0; n < cm->as->rank; n++)
2866 mpz_clear (lss->shape[n]);
2867 gfc_free (lss->shape);
2869 gfc_cleanup_loop (&loop);
2871 return gfc_finish_block (&block);
2875 /* Assign a single component of a derived type constructor. */
2878 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2888 gfc_start_block (&block);
2892 gfc_init_se (&se, NULL);
2893 /* Pointer component. */
2896 /* Array pointer. */
2897 if (expr->expr_type == EXPR_NULL)
2898 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2901 rss = gfc_walk_expr (expr);
2902 se.direct_byref = 1;
2904 gfc_conv_expr_descriptor (&se, expr, rss);
2905 gfc_add_block_to_block (&block, &se.pre);
2906 gfc_add_block_to_block (&block, &se.post);
2911 /* Scalar pointers. */
2912 se.want_pointer = 1;
2913 gfc_conv_expr (&se, expr);
2914 gfc_add_block_to_block (&block, &se.pre);
2915 gfc_add_modify_expr (&block, dest,
2916 fold_convert (TREE_TYPE (dest), se.expr));
2917 gfc_add_block_to_block (&block, &se.post);
2920 else if (cm->dimension)
2922 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2923 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2924 else if (cm->allocatable)
2928 gfc_init_se (&se, NULL);
2930 rss = gfc_walk_expr (expr);
2931 se.want_pointer = 0;
2932 gfc_conv_expr_descriptor (&se, expr, rss);
2933 gfc_add_block_to_block (&block, &se.pre);
2935 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2936 gfc_add_modify_expr (&block, dest, tmp);
2938 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2939 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2942 tmp = gfc_duplicate_allocatable (dest, se.expr,
2943 TREE_TYPE(cm->backend_decl),
2946 gfc_add_expr_to_block (&block, tmp);
2948 gfc_add_block_to_block (&block, &se.post);
2949 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2951 /* Shift the lbound and ubound of temporaries to being unity, rather
2952 than zero, based. Calculate the offset for all cases. */
2953 offset = gfc_conv_descriptor_offset (dest);
2954 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2955 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2956 for (n = 0; n < expr->rank; n++)
2958 if (expr->expr_type != EXPR_VARIABLE
2959 && expr->expr_type != EXPR_CONSTANT)
2961 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2962 gfc_add_modify_expr (&block, tmp,
2963 fold_build2 (PLUS_EXPR,
2964 gfc_array_index_type,
2965 tmp, gfc_index_one_node));
2966 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2967 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2969 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2970 gfc_conv_descriptor_lbound (dest,
2972 gfc_conv_descriptor_stride (dest,
2974 gfc_add_modify_expr (&block, tmp2, tmp);
2975 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2976 gfc_add_modify_expr (&block, offset, tmp);
2981 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2982 gfc_add_expr_to_block (&block, tmp);
2985 else if (expr->ts.type == BT_DERIVED)
2987 if (expr->expr_type != EXPR_STRUCTURE)
2989 gfc_init_se (&se, NULL);
2990 gfc_conv_expr (&se, expr);
2991 gfc_add_modify_expr (&block, dest,
2992 fold_convert (TREE_TYPE (dest), se.expr));
2996 /* Nested constructors. */
2997 tmp = gfc_trans_structure_assign (dest, expr);
2998 gfc_add_expr_to_block (&block, tmp);
3003 /* Scalar component. */
3004 gfc_init_se (&se, NULL);
3005 gfc_init_se (&lse, NULL);
3007 gfc_conv_expr (&se, expr);
3008 if (cm->ts.type == BT_CHARACTER)
3009 lse.string_length = cm->ts.cl->backend_decl;
3011 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3012 gfc_add_expr_to_block (&block, tmp);
3014 return gfc_finish_block (&block);
3017 /* Assign a derived type constructor to a variable. */
3020 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3028 gfc_start_block (&block);
3029 cm = expr->ts.derived->components;
3030 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3032 /* Skip absent members in default initializers. */
3036 field = cm->backend_decl;
3037 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3038 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3039 gfc_add_expr_to_block (&block, tmp);
3041 return gfc_finish_block (&block);
3044 /* Build an expression for a constructor. If init is nonzero then
3045 this is part of a static variable initializer. */
3048 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3055 VEC(constructor_elt,gc) *v = NULL;
3057 gcc_assert (se->ss == NULL);
3058 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3059 type = gfc_typenode_for_spec (&expr->ts);
3063 /* Create a temporary variable and fill it in. */
3064 se->expr = gfc_create_var (type, expr->ts.derived->name);
3065 tmp = gfc_trans_structure_assign (se->expr, expr);
3066 gfc_add_expr_to_block (&se->pre, tmp);
3070 cm = expr->ts.derived->components;
3072 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3074 /* Skip absent members in default initializers and allocatable
3075 components. Although the latter have a default initializer
3076 of EXPR_NULL,... by default, the static nullify is not needed
3077 since this is done every time we come into scope. */
3078 if (!c->expr || cm->allocatable)
3081 val = gfc_conv_initializer (c->expr, &cm->ts,
3082 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3084 /* Append it to the constructor list. */
3085 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3087 se->expr = build_constructor (type, v);
3091 /* Translate a substring expression. */
3094 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3100 gcc_assert (ref->type == REF_SUBSTRING);
3102 se->expr = gfc_build_string_const(expr->value.character.length,
3103 expr->value.character.string);
3104 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3105 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3107 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3111 /* Entry point for expression translation. Evaluates a scalar quantity.
3112 EXPR is the expression to be translated, and SE is the state structure if
3113 called from within the scalarized. */
3116 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3118 if (se->ss && se->ss->expr == expr
3119 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3121 /* Substitute a scalar expression evaluated outside the scalarization
3123 se->expr = se->ss->data.scalar.expr;
3124 se->string_length = se->ss->string_length;
3125 gfc_advance_se_ss_chain (se);
3129 switch (expr->expr_type)
3132 gfc_conv_expr_op (se, expr);
3136 gfc_conv_function_expr (se, expr);
3140 gfc_conv_constant (se, expr);
3144 gfc_conv_variable (se, expr);
3148 se->expr = null_pointer_node;
3151 case EXPR_SUBSTRING:
3152 gfc_conv_substring_expr (se, expr);
3155 case EXPR_STRUCTURE:
3156 gfc_conv_structure (se, expr, 0);
3160 gfc_conv_array_constructor_expr (se, expr);
3169 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3170 of an assignment. */
3172 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3174 gfc_conv_expr (se, expr);
3175 /* All numeric lvalues should have empty post chains. If not we need to
3176 figure out a way of rewriting an lvalue so that it has no post chain. */
3177 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3180 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3181 numeric expressions. Used for scalar values where inserting cleanup code
3184 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3188 gcc_assert (expr->ts.type != BT_CHARACTER);
3189 gfc_conv_expr (se, expr);
3192 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3193 gfc_add_modify_expr (&se->pre, val, se->expr);
3195 gfc_add_block_to_block (&se->pre, &se->post);
3199 /* Helper to translate and expression and convert it to a particular type. */
3201 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3203 gfc_conv_expr_val (se, expr);
3204 se->expr = convert (type, se->expr);
3208 /* Converts an expression so that it can be passed by reference. Scalar
3212 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3216 if (se->ss && se->ss->expr == expr
3217 && se->ss->type == GFC_SS_REFERENCE)
3219 se->expr = se->ss->data.scalar.expr;
3220 se->string_length = se->ss->string_length;
3221 gfc_advance_se_ss_chain (se);
3225 if (expr->ts.type == BT_CHARACTER)
3227 gfc_conv_expr (se, expr);
3228 gfc_conv_string_parameter (se);
3232 if (expr->expr_type == EXPR_VARIABLE)
3234 se->want_pointer = 1;
3235 gfc_conv_expr (se, expr);
3238 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3239 gfc_add_modify_expr (&se->pre, var, se->expr);
3240 gfc_add_block_to_block (&se->pre, &se->post);
3246 gfc_conv_expr (se, expr);
3248 /* Create a temporary var to hold the value. */
3249 if (TREE_CONSTANT (se->expr))
3251 tree tmp = se->expr;
3252 STRIP_TYPE_NOPS (tmp);
3253 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3254 DECL_INITIAL (var) = tmp;
3255 TREE_STATIC (var) = 1;
3260 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3261 gfc_add_modify_expr (&se->pre, var, se->expr);
3263 gfc_add_block_to_block (&se->pre, &se->post);
3265 /* Take the address of that value. */
3266 se->expr = build_fold_addr_expr (var);
3271 gfc_trans_pointer_assign (gfc_code * code)
3273 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3277 /* Generate code for a pointer assignment. */
3280 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3290 gfc_start_block (&block);
3292 gfc_init_se (&lse, NULL);
3294 lss = gfc_walk_expr (expr1);
3295 rss = gfc_walk_expr (expr2);
3296 if (lss == gfc_ss_terminator)
3298 /* Scalar pointers. */
3299 lse.want_pointer = 1;
3300 gfc_conv_expr (&lse, expr1);
3301 gcc_assert (rss == gfc_ss_terminator);
3302 gfc_init_se (&rse, NULL);
3303 rse.want_pointer = 1;
3304 gfc_conv_expr (&rse, expr2);
3305 gfc_add_block_to_block (&block, &lse.pre);
3306 gfc_add_block_to_block (&block, &rse.pre);
3307 gfc_add_modify_expr (&block, lse.expr,
3308 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3309 gfc_add_block_to_block (&block, &rse.post);
3310 gfc_add_block_to_block (&block, &lse.post);
3314 /* Array pointer. */
3315 gfc_conv_expr_descriptor (&lse, expr1, lss);
3316 switch (expr2->expr_type)
3319 /* Just set the data pointer to null. */
3320 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3324 /* Assign directly to the pointer's descriptor. */
3325 lse.direct_byref = 1;
3326 gfc_conv_expr_descriptor (&lse, expr2, rss);
3330 /* Assign to a temporary descriptor and then copy that
3331 temporary to the pointer. */
3333 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3336 lse.direct_byref = 1;
3337 gfc_conv_expr_descriptor (&lse, expr2, rss);
3338 gfc_add_modify_expr (&lse.pre, desc, tmp);
3341 gfc_add_block_to_block (&block, &lse.pre);
3342 gfc_add_block_to_block (&block, &lse.post);
3344 return gfc_finish_block (&block);
3348 /* Makes sure se is suitable for passing as a function string parameter. */
3349 /* TODO: Need to check all callers fo this function. It may be abused. */
3352 gfc_conv_string_parameter (gfc_se * se)
3356 if (TREE_CODE (se->expr) == STRING_CST)
3358 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3362 type = TREE_TYPE (se->expr);
3363 if (TYPE_STRING_FLAG (type))
3365 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3366 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3369 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3370 gcc_assert (se->string_length
3371 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3375 /* Generate code for assignment of scalar variables. Includes character
3376 strings and derived types with allocatable components. */
3379 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3380 bool l_is_temp, bool r_is_var)
3386 gfc_init_block (&block);
3388 if (ts.type == BT_CHARACTER)
3390 gcc_assert (lse->string_length != NULL_TREE
3391 && rse->string_length != NULL_TREE);
3393 gfc_conv_string_parameter (lse);
3394 gfc_conv_string_parameter (rse);
3396 gfc_add_block_to_block (&block, &lse->pre);
3397 gfc_add_block_to_block (&block, &rse->pre);
3399 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3400 rse->string_length, rse->expr);
3402 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3406 /* Are the rhs and the lhs the same? */
3409 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3410 build_fold_addr_expr (lse->expr),
3411 build_fold_addr_expr (rse->expr));
3412 cond = gfc_evaluate_now (cond, &lse->pre);
3415 /* Deallocate the lhs allocated components as long as it is not
3416 the same as the rhs. */
3419 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3421 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3422 gfc_add_expr_to_block (&lse->pre, tmp);
3425 gfc_add_block_to_block (&block, &lse->pre);
3426 gfc_add_block_to_block (&block, &rse->pre);
3428 gfc_add_modify_expr (&block, lse->expr,
3429 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3431 /* Do a deep copy if the rhs is a variable, if it is not the
3435 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3436 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3437 gfc_add_expr_to_block (&block, tmp);
3442 gfc_add_block_to_block (&block, &lse->pre);
3443 gfc_add_block_to_block (&block, &rse->pre);
3445 gfc_add_modify_expr (&block, lse->expr,
3446 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3449 gfc_add_block_to_block (&block, &lse->post);
3450 gfc_add_block_to_block (&block, &rse->post);
3452 return gfc_finish_block (&block);
3456 /* Try to translate array(:) = func (...), where func is a transformational
3457 array function, without using a temporary. Returns NULL is this isn't the
3461 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3466 bool seen_array_ref;
3468 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3469 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3472 /* Elemental functions don't need a temporary anyway. */
3473 if (expr2->value.function.esym != NULL
3474 && expr2->value.function.esym->attr.elemental)
3477 /* Fail if EXPR1 can't be expressed as a descriptor. */
3478 if (gfc_ref_needs_temporary_p (expr1->ref))
3481 /* Functions returning pointers need temporaries. */
3482 if (expr2->symtree->n.sym->attr.pointer
3483 || expr2->symtree->n.sym->attr.allocatable)
3486 /* Character array functions need temporaries unless the
3487 character lengths are the same. */
3488 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3490 if (expr1->ts.cl->length == NULL
3491 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3494 if (expr2->ts.cl->length == NULL
3495 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3498 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3499 expr2->ts.cl->length->value.integer) != 0)
3503 /* Check that no LHS component references appear during an array
3504 reference. This is needed because we do not have the means to
3505 span any arbitrary stride with an array descriptor. This check
3506 is not needed for the rhs because the function result has to be
3508 seen_array_ref = false;
3509 for (ref = expr1->ref; ref; ref = ref->next)
3511 if (ref->type == REF_ARRAY)
3512 seen_array_ref= true;
3513 else if (ref->type == REF_COMPONENT && seen_array_ref)
3517 /* Check for a dependency. */
3518 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3519 expr2->value.function.esym,
3520 expr2->value.function.actual))
3523 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3525 gcc_assert (expr2->value.function.isym
3526 || (gfc_return_by_reference (expr2->value.function.esym)
3527 && expr2->value.function.esym->result->attr.dimension));
3529 ss = gfc_walk_expr (expr1);
3530 gcc_assert (ss != gfc_ss_terminator);
3531 gfc_init_se (&se, NULL);
3532 gfc_start_block (&se.pre);
3533 se.want_pointer = 1;
3535 gfc_conv_array_parameter (&se, expr1, ss, 0);
3537 se.direct_byref = 1;
3538 se.ss = gfc_walk_expr (expr2);
3539 gcc_assert (se.ss != gfc_ss_terminator);
3540 gfc_conv_function_expr (&se, expr2);
3541 gfc_add_block_to_block (&se.pre, &se.post);
3543 return gfc_finish_block (&se.pre);
3546 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3549 is_zero_initializer_p (gfc_expr * expr)
3551 if (expr->expr_type != EXPR_CONSTANT)
3553 /* We ignore Hollerith constants for the time being. */
3557 switch (expr->ts.type)
3560 return mpz_cmp_si (expr->value.integer, 0) == 0;
3563 return mpfr_zero_p (expr->value.real)
3564 && MPFR_SIGN (expr->value.real) >= 0;
3567 return expr->value.logical == 0;
3570 return mpfr_zero_p (expr->value.complex.r)
3571 && MPFR_SIGN (expr->value.complex.r) >= 0
3572 && mpfr_zero_p (expr->value.complex.i)
3573 && MPFR_SIGN (expr->value.complex.i) >= 0;
3581 /* Try to efficiently translate array(:) = 0. Return NULL if this
3585 gfc_trans_zero_assign (gfc_expr * expr)
3587 tree dest, len, type;
3591 sym = expr->symtree->n.sym;
3592 dest = gfc_get_symbol_decl (sym);
3594 type = TREE_TYPE (dest);
3595 if (POINTER_TYPE_P (type))
3596 type = TREE_TYPE (type);
3597 if (!GFC_ARRAY_TYPE_P (type))
3600 /* Determine the length of the array. */
3601 len = GFC_TYPE_ARRAY_SIZE (type);
3602 if (!len || TREE_CODE (len) != INTEGER_CST)
3605 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3606 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
3608 /* Convert arguments to the correct types. */
3609 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3610 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3612 dest = fold_convert (pvoid_type_node, dest);
3613 len = fold_convert (size_type_node, len);
3615 /* Construct call to __builtin_memset. */
3616 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3617 3, dest, integer_zero_node, len);
3618 return fold_convert (void_type_node, tmp);
3622 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3623 that constructs the call to __builtin_memcpy. */
3626 gfc_build_memcpy_call (tree dst, tree src, tree len)
3630 /* Convert arguments to the correct types. */
3631 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3632 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3634 dst = fold_convert (pvoid_type_node, dst);
3636 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3637 src = gfc_build_addr_expr (pvoid_type_node, src);
3639 src = fold_convert (pvoid_type_node, src);
3641 len = fold_convert (size_type_node, len);
3643 /* Construct call to __builtin_memcpy. */
3644 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3645 return fold_convert (void_type_node, tmp);
3649 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3650 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3651 source/rhs, both are gfc_full_array_ref_p which have been checked for
3655 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3657 tree dst, dlen, dtype;
3658 tree src, slen, stype;
3660 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3661 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3663 dtype = TREE_TYPE (dst);
3664 if (POINTER_TYPE_P (dtype))
3665 dtype = TREE_TYPE (dtype);
3666 stype = TREE_TYPE (src);
3667 if (POINTER_TYPE_P (stype))
3668 stype = TREE_TYPE (stype);
3670 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3673 /* Determine the lengths of the arrays. */
3674 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3675 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3677 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3678 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3680 slen = GFC_TYPE_ARRAY_SIZE (stype);
3681 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3683 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3684 TYPE_SIZE_UNIT (gfc_get_element_type (stype)));
3686 /* Sanity check that they are the same. This should always be
3687 the case, as we should already have checked for conformance. */
3688 if (!tree_int_cst_equal (slen, dlen))
3691 return gfc_build_memcpy_call (dst, src, dlen);
3695 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3696 this can't be done. EXPR1 is the destination/lhs for which
3697 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3700 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3702 unsigned HOST_WIDE_INT nelem;
3707 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3711 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3712 dtype = TREE_TYPE (dst);
3713 if (POINTER_TYPE_P (dtype))
3714 dtype = TREE_TYPE (dtype);
3715 if (!GFC_ARRAY_TYPE_P (dtype))
3718 /* Determine the lengths of the array. */
3719 len = GFC_TYPE_ARRAY_SIZE (dtype);
3720 if (!len || TREE_CODE (len) != INTEGER_CST)
3723 /* Confirm that the constructor is the same size. */
3724 if (compare_tree_int (len, nelem) != 0)
3727 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3728 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3730 stype = gfc_typenode_for_spec (&expr2->ts);
3731 src = gfc_build_constant_array_constructor (expr2, stype);
3733 stype = TREE_TYPE (src);
3734 if (POINTER_TYPE_P (stype))
3735 stype = TREE_TYPE (stype);
3737 return gfc_build_memcpy_call (dst, src, len);
3741 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3742 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3745 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3750 gfc_ss *lss_section;
3758 /* Assignment of the form lhs = rhs. */
3759 gfc_start_block (&block);
3761 gfc_init_se (&lse, NULL);
3762 gfc_init_se (&rse, NULL);
3765 lss = gfc_walk_expr (expr1);
3767 if (lss != gfc_ss_terminator)
3769 /* The assignment needs scalarization. */
3772 /* Find a non-scalar SS from the lhs. */
3773 while (lss_section != gfc_ss_terminator
3774 && lss_section->type != GFC_SS_SECTION)
3775 lss_section = lss_section->next;
3777 gcc_assert (lss_section != gfc_ss_terminator);
3779 /* Initialize the scalarizer. */
3780 gfc_init_loopinfo (&loop);
3783 rss = gfc_walk_expr (expr2);
3784 if (rss == gfc_ss_terminator)
3786 /* The rhs is scalar. Add a ss for the expression. */
3787 rss = gfc_get_ss ();
3788 rss->next = gfc_ss_terminator;
3789 rss->type = GFC_SS_SCALAR;
3792 /* Associate the SS with the loop. */
3793 gfc_add_ss_to_loop (&loop, lss);
3794 gfc_add_ss_to_loop (&loop, rss);
3796 /* Calculate the bounds of the scalarization. */
3797 gfc_conv_ss_startstride (&loop);
3798 /* Resolve any data dependencies in the statement. */
3799 gfc_conv_resolve_dependencies (&loop, lss, rss);
3800 /* Setup the scalarizing loops. */
3801 gfc_conv_loop_setup (&loop);
3803 /* Setup the gfc_se structures. */
3804 gfc_copy_loopinfo_to_se (&lse, &loop);
3805 gfc_copy_loopinfo_to_se (&rse, &loop);
3808 gfc_mark_ss_chain_used (rss, 1);
3809 if (loop.temp_ss == NULL)
3812 gfc_mark_ss_chain_used (lss, 1);
3816 lse.ss = loop.temp_ss;
3817 gfc_mark_ss_chain_used (lss, 3);
3818 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3821 /* Start the scalarized loop body. */
3822 gfc_start_scalarized_body (&loop, &body);
3825 gfc_init_block (&body);
3827 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3829 /* Translate the expression. */
3830 gfc_conv_expr (&rse, expr2);
3834 gfc_conv_tmp_array_ref (&lse);
3835 gfc_advance_se_ss_chain (&lse);
3838 gfc_conv_expr (&lse, expr1);
3840 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3841 l_is_temp || init_flag,
3842 expr2->expr_type == EXPR_VARIABLE);
3843 gfc_add_expr_to_block (&body, tmp);
3845 if (lss == gfc_ss_terminator)
3847 /* Use the scalar assignment as is. */
3848 gfc_add_block_to_block (&block, &body);
3852 gcc_assert (lse.ss == gfc_ss_terminator
3853 && rse.ss == gfc_ss_terminator);
3857 gfc_trans_scalarized_loop_boundary (&loop, &body);
3859 /* We need to copy the temporary to the actual lhs. */
3860 gfc_init_se (&lse, NULL);
3861 gfc_init_se (&rse, NULL);
3862 gfc_copy_loopinfo_to_se (&lse, &loop);
3863 gfc_copy_loopinfo_to_se (&rse, &loop);
3865 rse.ss = loop.temp_ss;
3868 gfc_conv_tmp_array_ref (&rse);
3869 gfc_advance_se_ss_chain (&rse);
3870 gfc_conv_expr (&lse, expr1);
3872 gcc_assert (lse.ss == gfc_ss_terminator
3873 && rse.ss == gfc_ss_terminator);
3875 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3877 gfc_add_expr_to_block (&body, tmp);
3880 /* Generate the copying loops. */
3881 gfc_trans_scalarizing_loops (&loop, &body);
3883 /* Wrap the whole thing up. */
3884 gfc_add_block_to_block (&block, &loop.pre);
3885 gfc_add_block_to_block (&block, &loop.post);
3887 gfc_cleanup_loop (&loop);
3890 return gfc_finish_block (&block);
3894 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3897 copyable_array_p (gfc_expr * expr)
3899 /* First check it's an array. */
3900 if (expr->rank < 1 || !expr->ref)
3903 /* Next check that it's of a simple enough type. */
3904 switch (expr->ts.type)
3916 return !expr->ts.derived->attr.alloc_comp;
3925 /* Translate an assignment. */
3928 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3932 /* Special case a single function returning an array. */
3933 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3935 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3940 /* Special case assigning an array to zero. */
3941 if (expr1->expr_type == EXPR_VARIABLE
3944 && gfc_full_array_ref_p (expr1->ref)
3945 && is_zero_initializer_p (expr2))
3947 tmp = gfc_trans_zero_assign (expr1);
3952 /* Special case copying one array to another. */
3953 if (expr1->expr_type == EXPR_VARIABLE
3954 && copyable_array_p (expr1)
3955 && gfc_full_array_ref_p (expr1->ref)
3956 && expr2->expr_type == EXPR_VARIABLE
3957 && copyable_array_p (expr2)
3958 && gfc_full_array_ref_p (expr2->ref)
3959 && gfc_compare_types (&expr1->ts, &expr2->ts)
3960 && !gfc_check_dependency (expr1, expr2, 0))
3962 tmp = gfc_trans_array_copy (expr1, expr2);
3967 /* Special case initializing an array from a constant array constructor. */
3968 if (expr1->expr_type == EXPR_VARIABLE
3969 && copyable_array_p (expr1)
3970 && gfc_full_array_ref_p (expr1->ref)
3971 && expr2->expr_type == EXPR_ARRAY
3972 && gfc_compare_types (&expr1->ts, &expr2->ts))
3974 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
3979 /* Fallback to the scalarizer to generate explicit loops. */
3980 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
3984 gfc_trans_init_assign (gfc_code * code)
3986 return gfc_trans_assignment (code->expr, code->expr2, true);
3990 gfc_trans_assign (gfc_code * code)
3992 return gfc_trans_assignment (code->expr, code->expr2, false);