1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
46 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
55 dest->loop = src->loop;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se * se, gfc_se * parent)
68 memset (se, 0, sizeof (gfc_se));
69 gfc_init_block (&se->pre);
70 gfc_init_block (&se->post);
75 gfc_copy_se_loopvars (se, parent);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se * se)
88 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se * se)
112 if (CONSTANT_CLASS_P (se->expr))
115 /* We need a temporary for this result. */
116 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
117 gfc_add_modify_expr (&se->pre, var, se->expr);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol * sym)
130 gcc_assert (sym->attr.dummy);
132 decl = gfc_get_symbol_decl (sym);
133 if (TREE_CODE (decl) != PARM_DECL)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
139 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 return build2 (NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
154 present = gfc_conv_expr_present (arg->symtree->n.sym);
155 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
156 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
158 tmp = gfc_evaluate_now (tmp, &se->pre);
160 if (ts.type == BT_CHARACTER)
162 tmp = build_int_cst (gfc_charlen_type_node, 0);
163 tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
164 se->string_length, tmp);
165 tmp = gfc_evaluate_now (tmp, &se->pre);
166 se->string_length = tmp;
172 /* Get the character length of an expression, looking through gfc_refs
176 gfc_get_expr_charlen (gfc_expr *e)
181 gcc_assert (e->expr_type == EXPR_VARIABLE
182 && e->ts.type == BT_CHARACTER);
184 length = NULL; /* To silence compiler warning. */
186 /* First candidate: if the variable is of type CHARACTER, the
187 expression's length could be the length of the character
189 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
190 length = e->symtree->n.sym->ts.cl->backend_decl;
192 /* Look through the reference chain for component references. */
193 for (r = e->ref; r; r = r->next)
198 if (r->u.c.component->ts.type == BT_CHARACTER)
199 length = r->u.c.component->ts.cl->backend_decl;
207 /* We should never got substring references here. These will be
208 broken down by the scalarizer. */
213 gcc_assert (length != NULL);
219 /* Generate code to initialize a string length variable. Returns the
223 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
228 gfc_init_se (&se, NULL);
229 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
230 gfc_add_block_to_block (pblock, &se.pre);
232 tmp = cl->backend_decl;
233 gfc_add_modify_expr (pblock, tmp, se.expr);
238 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
239 const char *name, locus *where)
249 type = gfc_get_character_type (kind, ref->u.ss.length);
250 type = build_pointer_type (type);
253 gfc_init_se (&start, se);
254 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
255 gfc_add_block_to_block (&se->pre, &start.pre);
257 if (integer_onep (start.expr))
258 gfc_conv_string_parameter (se);
261 /* Change the start of the string. */
262 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
265 tmp = build_fold_indirect_ref (se->expr);
266 tmp = gfc_build_array_ref (tmp, start.expr);
267 se->expr = gfc_build_addr_expr (type, tmp);
270 /* Length = end + 1 - start. */
271 gfc_init_se (&end, se);
272 if (ref->u.ss.end == NULL)
273 end.expr = se->string_length;
276 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
277 gfc_add_block_to_block (&se->pre, &end.pre);
279 if (flag_bounds_check)
281 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
282 start.expr, end.expr);
284 /* Check lower bound. */
285 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
286 build_int_cst (gfc_charlen_type_node, 1));
287 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
290 asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
291 "is less than one", name);
293 asprintf (&msg, "Substring out of bounds: lower bound "
295 gfc_trans_runtime_check (fault, msg, &se->pre, where);
298 /* Check upper bound. */
299 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
301 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
304 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
305 "exceeds string length", name);
307 asprintf (&msg, "Substring out of bounds: upper bound "
308 "exceeds string length");
309 gfc_trans_runtime_check (fault, msg, &se->pre, where);
313 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
314 build_int_cst (gfc_charlen_type_node, 1),
316 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
317 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
318 build_int_cst (gfc_charlen_type_node, 0));
319 se->string_length = tmp;
323 /* Convert a derived type component reference. */
326 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
333 c = ref->u.c.component;
335 gcc_assert (c->backend_decl);
337 field = c->backend_decl;
338 gcc_assert (TREE_CODE (field) == FIELD_DECL);
340 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
344 if (c->ts.type == BT_CHARACTER)
346 tmp = c->ts.cl->backend_decl;
347 /* Components must always be constant length. */
348 gcc_assert (tmp && INTEGER_CST_P (tmp));
349 se->string_length = tmp;
352 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
353 se->expr = build_fold_indirect_ref (se->expr);
357 /* Return the contents of a variable. Also handles reference/pointer
358 variables (all Fortran pointer references are implicit). */
361 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
368 bool alternate_entry;
371 sym = expr->symtree->n.sym;
374 /* Check that something hasn't gone horribly wrong. */
375 gcc_assert (se->ss != gfc_ss_terminator);
376 gcc_assert (se->ss->expr == expr);
378 /* A scalarized term. We already know the descriptor. */
379 se->expr = se->ss->data.info.descriptor;
380 se->string_length = se->ss->string_length;
381 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
382 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
387 tree se_expr = NULL_TREE;
389 se->expr = gfc_get_symbol_decl (sym);
391 /* Deal with references to a parent results or entries by storing
392 the current_function_decl and moving to the parent_decl. */
393 return_value = sym->attr.function && sym->result == sym;
394 alternate_entry = sym->attr.function && sym->attr.entry
395 && sym->result == sym;
396 entry_master = sym->attr.result
397 && sym->ns->proc_name->attr.entry_master
398 && !gfc_return_by_reference (sym->ns->proc_name);
399 parent_decl = DECL_CONTEXT (current_function_decl);
401 if ((se->expr == parent_decl && return_value)
402 || (sym->ns && sym->ns->proc_name
404 && sym->ns->proc_name->backend_decl == parent_decl
405 && (alternate_entry || entry_master)))
410 /* Special case for assigning the return value of a function.
411 Self recursive functions must have an explicit return value. */
412 if (return_value && (se->expr == current_function_decl || parent_flag))
413 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
415 /* Similarly for alternate entry points. */
416 else if (alternate_entry
417 && (sym->ns->proc_name->backend_decl == current_function_decl
420 gfc_entry_list *el = NULL;
422 for (el = sym->ns->entries; el; el = el->next)
425 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
430 else if (entry_master
431 && (sym->ns->proc_name->backend_decl == current_function_decl
433 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
438 /* Procedure actual arguments. */
439 else if (sym->attr.flavor == FL_PROCEDURE
440 && se->expr != current_function_decl)
442 gcc_assert (se->want_pointer);
443 if (!sym->attr.dummy)
445 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
446 se->expr = build_fold_addr_expr (se->expr);
452 /* Dereference the expression, where needed. Since characters
453 are entirely different from other types, they are treated
455 if (sym->ts.type == BT_CHARACTER)
457 /* Dereference character pointer dummy arguments
459 if ((sym->attr.pointer || sym->attr.allocatable)
461 || sym->attr.function
462 || sym->attr.result))
463 se->expr = build_fold_indirect_ref (se->expr);
465 /* A character with VALUE attribute needs an address
468 se->expr = build_fold_addr_expr (se->expr);
471 else if (!sym->attr.value)
473 /* Dereference non-character scalar dummy arguments. */
474 if (sym->attr.dummy && !sym->attr.dimension)
475 se->expr = build_fold_indirect_ref (se->expr);
477 /* Dereference scalar hidden result. */
478 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
479 && (sym->attr.function || sym->attr.result)
480 && !sym->attr.dimension && !sym->attr.pointer)
481 se->expr = build_fold_indirect_ref (se->expr);
483 /* Dereference non-character pointer variables.
484 These must be dummies, results, or scalars. */
485 if ((sym->attr.pointer || sym->attr.allocatable)
487 || sym->attr.function
489 || !sym->attr.dimension))
490 se->expr = build_fold_indirect_ref (se->expr);
496 /* For character variables, also get the length. */
497 if (sym->ts.type == BT_CHARACTER)
499 /* If the character length of an entry isn't set, get the length from
500 the master function instead. */
501 if (sym->attr.entry && !sym->ts.cl->backend_decl)
502 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
504 se->string_length = sym->ts.cl->backend_decl;
505 gcc_assert (se->string_length);
513 /* Return the descriptor if that's what we want and this is an array
514 section reference. */
515 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
517 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
518 /* Return the descriptor for array pointers and allocations. */
520 && ref->next == NULL && (se->descriptor_only))
523 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
524 /* Return a pointer to an element. */
528 gfc_conv_component_ref (se, ref);
532 gfc_conv_substring (se, ref, expr->ts.kind,
533 expr->symtree->name, &expr->where);
542 /* Pointer assignment, allocation or pass by reference. Arrays are handled
544 if (se->want_pointer)
546 if (expr->ts.type == BT_CHARACTER)
547 gfc_conv_string_parameter (se);
549 se->expr = build_fold_addr_expr (se->expr);
554 /* Unary ops are easy... Or they would be if ! was a valid op. */
557 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
562 gcc_assert (expr->ts.type != BT_CHARACTER);
563 /* Initialize the operand. */
564 gfc_init_se (&operand, se);
565 gfc_conv_expr_val (&operand, expr->value.op.op1);
566 gfc_add_block_to_block (&se->pre, &operand.pre);
568 type = gfc_typenode_for_spec (&expr->ts);
570 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
571 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
572 All other unary operators have an equivalent GIMPLE unary operator. */
573 if (code == TRUTH_NOT_EXPR)
574 se->expr = build2 (EQ_EXPR, type, operand.expr,
575 build_int_cst (type, 0));
577 se->expr = build1 (code, type, operand.expr);
581 /* Expand power operator to optimal multiplications when a value is raised
582 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
583 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
584 Programming", 3rd Edition, 1998. */
586 /* This code is mostly duplicated from expand_powi in the backend.
587 We establish the "optimal power tree" lookup table with the defined size.
588 The items in the table are the exponents used to calculate the index
589 exponents. Any integer n less than the value can get an "addition chain",
590 with the first node being one. */
591 #define POWI_TABLE_SIZE 256
593 /* The table is from builtins.c. */
594 static const unsigned char powi_table[POWI_TABLE_SIZE] =
596 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
597 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
598 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
599 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
600 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
601 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
602 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
603 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
604 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
605 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
606 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
607 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
608 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
609 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
610 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
611 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
612 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
613 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
614 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
615 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
616 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
617 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
618 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
619 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
620 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
621 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
622 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
623 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
624 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
625 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
626 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
627 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
630 /* If n is larger than lookup table's max index, we use the "window
632 #define POWI_WINDOW_SIZE 3
634 /* Recursive function to expand the power operator. The temporary
635 values are put in tmpvar. The function returns tmpvar[1] ** n. */
637 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
644 if (n < POWI_TABLE_SIZE)
649 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
650 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
654 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
655 op0 = gfc_conv_powi (se, n - digit, tmpvar);
656 op1 = gfc_conv_powi (se, digit, tmpvar);
660 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
664 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
665 tmp = gfc_evaluate_now (tmp, &se->pre);
667 if (n < POWI_TABLE_SIZE)
674 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
675 return 1. Else return 0 and a call to runtime library functions
676 will have to be built. */
678 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
683 tree vartmp[POWI_TABLE_SIZE];
687 type = TREE_TYPE (lhs);
688 n = abs (TREE_INT_CST_LOW (rhs));
689 sgn = tree_int_cst_sgn (rhs);
691 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
692 && (n > 2 || n < -1))
698 se->expr = gfc_build_const (type, integer_one_node);
701 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
702 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
704 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
705 build_int_cst (TREE_TYPE (lhs), -1));
706 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
707 build_int_cst (TREE_TYPE (lhs), 1));
710 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
713 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
714 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
715 build_int_cst (type, 0));
719 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
720 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
721 build_int_cst (type, 0));
722 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
726 memset (vartmp, 0, sizeof (vartmp));
730 tmp = gfc_build_const (type, integer_one_node);
731 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
734 se->expr = gfc_conv_powi (se, n, vartmp);
740 /* Power op (**). Constant integer exponent has special handling. */
743 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
745 tree gfc_int4_type_node;
753 gfc_init_se (&lse, se);
754 gfc_conv_expr_val (&lse, expr->value.op.op1);
755 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
756 gfc_add_block_to_block (&se->pre, &lse.pre);
758 gfc_init_se (&rse, se);
759 gfc_conv_expr_val (&rse, expr->value.op.op2);
760 gfc_add_block_to_block (&se->pre, &rse.pre);
762 if (expr->value.op.op2->ts.type == BT_INTEGER
763 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
764 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
767 gfc_int4_type_node = gfc_get_int_type (4);
769 kind = expr->value.op.op1->ts.kind;
770 switch (expr->value.op.op2->ts.type)
773 ikind = expr->value.op.op2->ts.kind;
778 rse.expr = convert (gfc_int4_type_node, rse.expr);
800 if (expr->value.op.op1->ts.type == BT_INTEGER)
801 lse.expr = convert (gfc_int4_type_node, lse.expr);
826 switch (expr->value.op.op1->ts.type)
829 if (kind == 3) /* Case 16 was not handled properly above. */
831 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
835 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
839 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
851 fndecl = built_in_decls[BUILT_IN_POWF];
854 fndecl = built_in_decls[BUILT_IN_POW];
858 fndecl = built_in_decls[BUILT_IN_POWL];
869 fndecl = gfor_fndecl_math_cpowf;
872 fndecl = gfor_fndecl_math_cpow;
875 fndecl = gfor_fndecl_math_cpowl10;
878 fndecl = gfor_fndecl_math_cpowl16;
890 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
891 tmp = gfc_chainon_list (tmp, rse.expr);
892 se->expr = build_function_call_expr (fndecl, tmp);
896 /* Generate code to allocate a string temporary. */
899 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
905 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
907 if (gfc_can_put_var_on_stack (len))
909 /* Create a temporary variable to hold the result. */
910 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
911 build_int_cst (gfc_charlen_type_node, 1));
912 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
913 tmp = build_array_type (gfc_character1_type_node, tmp);
914 var = gfc_create_var (tmp, "str");
915 var = gfc_build_addr_expr (type, var);
919 /* Allocate a temporary to hold the result. */
920 var = gfc_create_var (type, "pstr");
921 args = gfc_chainon_list (NULL_TREE, len);
922 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
923 tmp = convert (type, tmp);
924 gfc_add_modify_expr (&se->pre, var, tmp);
926 /* Free the temporary afterwards. */
927 tmp = convert (pvoid_type_node, var);
928 args = gfc_chainon_list (NULL_TREE, tmp);
929 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
930 gfc_add_expr_to_block (&se->post, tmp);
937 /* Handle a string concatenation operation. A temporary will be allocated to
941 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
951 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
952 && expr->value.op.op2->ts.type == BT_CHARACTER);
954 gfc_init_se (&lse, se);
955 gfc_conv_expr (&lse, expr->value.op.op1);
956 gfc_conv_string_parameter (&lse);
957 gfc_init_se (&rse, se);
958 gfc_conv_expr (&rse, expr->value.op.op2);
959 gfc_conv_string_parameter (&rse);
961 gfc_add_block_to_block (&se->pre, &lse.pre);
962 gfc_add_block_to_block (&se->pre, &rse.pre);
964 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
965 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
966 if (len == NULL_TREE)
968 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
969 lse.string_length, rse.string_length);
972 type = build_pointer_type (type);
974 var = gfc_conv_string_tmp (se, type, len);
976 /* Do the actual concatenation. */
978 args = gfc_chainon_list (args, len);
979 args = gfc_chainon_list (args, var);
980 args = gfc_chainon_list (args, lse.string_length);
981 args = gfc_chainon_list (args, lse.expr);
982 args = gfc_chainon_list (args, rse.string_length);
983 args = gfc_chainon_list (args, rse.expr);
984 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
985 gfc_add_expr_to_block (&se->pre, tmp);
987 /* Add the cleanup for the operands. */
988 gfc_add_block_to_block (&se->pre, &rse.post);
989 gfc_add_block_to_block (&se->pre, &lse.post);
992 se->string_length = len;
995 /* Translates an op expression. Common (binary) cases are handled by this
996 function, others are passed on. Recursion is used in either case.
997 We use the fact that (op1.ts == op2.ts) (except for the power
999 Operators need no special handling for scalarized expressions as long as
1000 they call gfc_conv_simple_val to get their operands.
1001 Character strings get special handling. */
1004 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1006 enum tree_code code;
1016 switch (expr->value.op.operator)
1018 case INTRINSIC_UPLUS:
1019 case INTRINSIC_PARENTHESES:
1020 gfc_conv_expr (se, expr->value.op.op1);
1023 case INTRINSIC_UMINUS:
1024 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1028 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1031 case INTRINSIC_PLUS:
1035 case INTRINSIC_MINUS:
1039 case INTRINSIC_TIMES:
1043 case INTRINSIC_DIVIDE:
1044 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1045 an integer, we must round towards zero, so we use a
1047 if (expr->ts.type == BT_INTEGER)
1048 code = TRUNC_DIV_EXPR;
1053 case INTRINSIC_POWER:
1054 gfc_conv_power_op (se, expr);
1057 case INTRINSIC_CONCAT:
1058 gfc_conv_concat_op (se, expr);
1062 code = TRUTH_ANDIF_EXPR;
1067 code = TRUTH_ORIF_EXPR;
1071 /* EQV and NEQV only work on logicals, but since we represent them
1072 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1081 case INTRINSIC_NEQV:
1111 case INTRINSIC_USER:
1112 case INTRINSIC_ASSIGN:
1113 /* These should be converted into function calls by the frontend. */
1117 fatal_error ("Unknown intrinsic op");
1121 /* The only exception to this is **, which is handled separately anyway. */
1122 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1124 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1128 gfc_init_se (&lse, se);
1129 gfc_conv_expr (&lse, expr->value.op.op1);
1130 gfc_add_block_to_block (&se->pre, &lse.pre);
1133 gfc_init_se (&rse, se);
1134 gfc_conv_expr (&rse, expr->value.op.op2);
1135 gfc_add_block_to_block (&se->pre, &rse.pre);
1139 gfc_conv_string_parameter (&lse);
1140 gfc_conv_string_parameter (&rse);
1142 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1143 rse.string_length, rse.expr);
1144 rse.expr = integer_zero_node;
1145 gfc_add_block_to_block (&lse.post, &rse.post);
1148 type = gfc_typenode_for_spec (&expr->ts);
1152 /* The result of logical ops is always boolean_type_node. */
1153 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1154 se->expr = convert (type, tmp);
1157 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1159 /* Add the post blocks. */
1160 gfc_add_block_to_block (&se->post, &rse.post);
1161 gfc_add_block_to_block (&se->post, &lse.post);
1164 /* If a string's length is one, we convert it to a single character. */
1167 gfc_to_single_character (tree len, tree str)
1169 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1171 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1172 && TREE_INT_CST_HIGH (len) == 0)
1174 str = fold_convert (pchar_type_node, str);
1175 return build_fold_indirect_ref (str);
1181 /* Compare two strings. If they are all single characters, the result is the
1182 subtraction of them. Otherwise, we build a library call. */
1185 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1192 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1193 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1195 type = gfc_get_int_type (gfc_default_integer_kind);
1197 sc1 = gfc_to_single_character (len1, str1);
1198 sc2 = gfc_to_single_character (len2, str2);
1200 /* Deal with single character specially. */
1201 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1203 sc1 = fold_convert (type, sc1);
1204 sc2 = fold_convert (type, sc2);
1205 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1210 tmp = gfc_chainon_list (tmp, len1);
1211 tmp = gfc_chainon_list (tmp, str1);
1212 tmp = gfc_chainon_list (tmp, len2);
1213 tmp = gfc_chainon_list (tmp, str2);
1215 /* Build a call for the comparison. */
1216 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1223 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1227 if (sym->attr.dummy)
1229 tmp = gfc_get_symbol_decl (sym);
1230 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1231 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1235 if (!sym->backend_decl)
1236 sym->backend_decl = gfc_get_extern_function_decl (sym);
1238 tmp = sym->backend_decl;
1239 if (sym->attr.cray_pointee)
1240 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1241 gfc_get_symbol_decl (sym->cp_pointer));
1242 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1244 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1245 tmp = build_fold_addr_expr (tmp);
1252 /* Translate the call for an elemental subroutine call used in an operator
1253 assignment. This is a simplified version of gfc_conv_function_call. */
1256 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1263 /* Only elemental subroutines with two arguments. */
1264 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1265 gcc_assert (sym->formal->next->next == NULL);
1267 gfc_init_block (&block);
1269 gfc_add_block_to_block (&block, &lse->pre);
1270 gfc_add_block_to_block (&block, &rse->pre);
1272 /* Build the argument list for the call, including hidden string lengths. */
1273 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1274 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1275 if (lse->string_length != NULL_TREE)
1276 args = gfc_chainon_list (args, lse->string_length);
1277 if (rse->string_length != NULL_TREE)
1278 args = gfc_chainon_list (args, rse->string_length);
1280 /* Build the function call. */
1281 gfc_init_se (&se, NULL);
1282 gfc_conv_function_val (&se, sym);
1283 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1284 tmp = build3 (CALL_EXPR, tmp, se.expr, args, NULL_TREE);
1285 gfc_add_expr_to_block (&block, tmp);
1287 gfc_add_block_to_block (&block, &lse->post);
1288 gfc_add_block_to_block (&block, &rse->post);
1290 return gfc_finish_block (&block);
1294 /* Initialize MAPPING. */
1297 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1299 mapping->syms = NULL;
1300 mapping->charlens = NULL;
1304 /* Free all memory held by MAPPING (but not MAPPING itself). */
1307 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1309 gfc_interface_sym_mapping *sym;
1310 gfc_interface_sym_mapping *nextsym;
1312 gfc_charlen *nextcl;
1314 for (sym = mapping->syms; sym; sym = nextsym)
1316 nextsym = sym->next;
1317 gfc_free_symbol (sym->new->n.sym);
1318 gfc_free (sym->new);
1321 for (cl = mapping->charlens; cl; cl = nextcl)
1324 gfc_free_expr (cl->length);
1330 /* Return a copy of gfc_charlen CL. Add the returned structure to
1331 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1333 static gfc_charlen *
1334 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1339 new = gfc_get_charlen ();
1340 new->next = mapping->charlens;
1341 new->length = gfc_copy_expr (cl->length);
1343 mapping->charlens = new;
1348 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1349 array variable that can be used as the actual argument for dummy
1350 argument SYM. Add any initialization code to BLOCK. PACKED is as
1351 for gfc_get_nodesc_array_type and DATA points to the first element
1352 in the passed array. */
1355 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1356 int packed, tree data)
1361 type = gfc_typenode_for_spec (&sym->ts);
1362 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1364 var = gfc_create_var (type, "ifm");
1365 gfc_add_modify_expr (block, var, fold_convert (type, data));
1371 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1372 and offset of descriptorless array type TYPE given that it has the same
1373 size as DESC. Add any set-up code to BLOCK. */
1376 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1383 offset = gfc_index_zero_node;
1384 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1386 dim = gfc_rank_cst[n];
1387 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1388 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1390 GFC_TYPE_ARRAY_LBOUND (type, n)
1391 = gfc_conv_descriptor_lbound (desc, dim);
1392 GFC_TYPE_ARRAY_UBOUND (type, n)
1393 = gfc_conv_descriptor_ubound (desc, dim);
1395 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1397 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1398 gfc_conv_descriptor_ubound (desc, dim),
1399 gfc_conv_descriptor_lbound (desc, dim));
1400 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1401 GFC_TYPE_ARRAY_LBOUND (type, n),
1403 tmp = gfc_evaluate_now (tmp, block);
1404 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1406 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1407 GFC_TYPE_ARRAY_LBOUND (type, n),
1408 GFC_TYPE_ARRAY_STRIDE (type, n));
1409 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1411 offset = gfc_evaluate_now (offset, block);
1412 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1416 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1417 in SE. The caller may still use se->expr and se->string_length after
1418 calling this function. */
1421 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1422 gfc_symbol * sym, gfc_se * se)
1424 gfc_interface_sym_mapping *sm;
1428 gfc_symbol *new_sym;
1430 gfc_symtree *new_symtree;
1432 /* Create a new symbol to represent the actual argument. */
1433 new_sym = gfc_new_symbol (sym->name, NULL);
1434 new_sym->ts = sym->ts;
1435 new_sym->attr.referenced = 1;
1436 new_sym->attr.dimension = sym->attr.dimension;
1437 new_sym->attr.pointer = sym->attr.pointer;
1438 new_sym->attr.allocatable = sym->attr.allocatable;
1439 new_sym->attr.flavor = sym->attr.flavor;
1441 /* Create a fake symtree for it. */
1443 new_symtree = gfc_new_symtree (&root, sym->name);
1444 new_symtree->n.sym = new_sym;
1445 gcc_assert (new_symtree == root);
1447 /* Create a dummy->actual mapping. */
1448 sm = gfc_getmem (sizeof (*sm));
1449 sm->next = mapping->syms;
1451 sm->new = new_symtree;
1454 /* Stabilize the argument's value. */
1455 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1457 if (sym->ts.type == BT_CHARACTER)
1459 /* Create a copy of the dummy argument's length. */
1460 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1462 /* If the length is specified as "*", record the length that
1463 the caller is passing. We should use the callee's length
1464 in all other cases. */
1465 if (!new_sym->ts.cl->length)
1467 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1468 new_sym->ts.cl->backend_decl = se->string_length;
1472 /* Use the passed value as-is if the argument is a function. */
1473 if (sym->attr.flavor == FL_PROCEDURE)
1476 /* If the argument is either a string or a pointer to a string,
1477 convert it to a boundless character type. */
1478 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1480 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1481 tmp = build_pointer_type (tmp);
1482 if (sym->attr.pointer)
1483 value = build_fold_indirect_ref (se->expr);
1486 value = fold_convert (tmp, value);
1489 /* If the argument is a scalar, a pointer to an array or an allocatable,
1491 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1492 value = build_fold_indirect_ref (se->expr);
1494 /* For character(*), use the actual argument's descriptor. */
1495 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1496 value = build_fold_indirect_ref (se->expr);
1498 /* If the argument is an array descriptor, use it to determine
1499 information about the actual argument's shape. */
1500 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1501 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1503 /* Get the actual argument's descriptor. */
1504 desc = build_fold_indirect_ref (se->expr);
1506 /* Create the replacement variable. */
1507 tmp = gfc_conv_descriptor_data_get (desc);
1508 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1510 /* Use DESC to work out the upper bounds, strides and offset. */
1511 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1514 /* Otherwise we have a packed array. */
1515 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1517 new_sym->backend_decl = value;
1521 /* Called once all dummy argument mappings have been added to MAPPING,
1522 but before the mapping is used to evaluate expressions. Pre-evaluate
1523 the length of each argument, adding any initialization code to PRE and
1524 any finalization code to POST. */
1527 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1528 stmtblock_t * pre, stmtblock_t * post)
1530 gfc_interface_sym_mapping *sym;
1534 for (sym = mapping->syms; sym; sym = sym->next)
1535 if (sym->new->n.sym->ts.type == BT_CHARACTER
1536 && !sym->new->n.sym->ts.cl->backend_decl)
1538 expr = sym->new->n.sym->ts.cl->length;
1539 gfc_apply_interface_mapping_to_expr (mapping, expr);
1540 gfc_init_se (&se, NULL);
1541 gfc_conv_expr (&se, expr);
1543 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1544 gfc_add_block_to_block (pre, &se.pre);
1545 gfc_add_block_to_block (post, &se.post);
1547 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1552 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1556 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1557 gfc_constructor * c)
1559 for (; c; c = c->next)
1561 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1564 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1565 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1566 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1572 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1576 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1581 for (; ref; ref = ref->next)
1585 for (n = 0; n < ref->u.ar.dimen; n++)
1587 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1588 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1589 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1591 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1598 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1599 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1605 /* EXPR is a copy of an expression that appeared in the interface
1606 associated with MAPPING. Walk it recursively looking for references to
1607 dummy arguments that MAPPING maps to actual arguments. Replace each such
1608 reference with a reference to the associated actual argument. */
1611 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1614 gfc_interface_sym_mapping *sym;
1615 gfc_actual_arglist *actual;
1620 /* Copying an expression does not copy its length, so do that here. */
1621 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1623 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1624 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1627 /* Apply the mapping to any references. */
1628 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1630 /* ...and to the expression's symbol, if it has one. */
1632 for (sym = mapping->syms; sym; sym = sym->next)
1633 if (sym->old == expr->symtree->n.sym)
1634 expr->symtree = sym->new;
1636 /* ...and to subexpressions in expr->value. */
1637 switch (expr->expr_type)
1642 case EXPR_SUBSTRING:
1646 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1647 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1651 for (sym = mapping->syms; sym; sym = sym->next)
1652 if (sym->old == expr->value.function.esym)
1653 expr->value.function.esym = sym->new->n.sym;
1655 for (actual = expr->value.function.actual; actual; actual = actual->next)
1656 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1660 case EXPR_STRUCTURE:
1661 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1667 /* Evaluate interface expression EXPR using MAPPING. Store the result
1671 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1672 gfc_se * se, gfc_expr * expr)
1674 expr = gfc_copy_expr (expr);
1675 gfc_apply_interface_mapping_to_expr (mapping, expr);
1676 gfc_conv_expr (se, expr);
1677 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1678 gfc_free_expr (expr);
1681 /* Returns a reference to a temporary array into which a component of
1682 an actual argument derived type array is copied and then returned
1683 after the function call.
1684 TODO Get rid of this kludge, when array descriptors are capable of
1685 handling aliased arrays. */
1688 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1689 int g77, sym_intent intent)
1705 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1707 gfc_init_se (&lse, NULL);
1708 gfc_init_se (&rse, NULL);
1710 /* Walk the argument expression. */
1711 rss = gfc_walk_expr (expr);
1713 gcc_assert (rss != gfc_ss_terminator);
1715 /* Initialize the scalarizer. */
1716 gfc_init_loopinfo (&loop);
1717 gfc_add_ss_to_loop (&loop, rss);
1719 /* Calculate the bounds of the scalarization. */
1720 gfc_conv_ss_startstride (&loop);
1722 /* Build an ss for the temporary. */
1723 base_type = gfc_typenode_for_spec (&expr->ts);
1724 if (GFC_ARRAY_TYPE_P (base_type)
1725 || GFC_DESCRIPTOR_TYPE_P (base_type))
1726 base_type = gfc_get_element_type (base_type);
1728 loop.temp_ss = gfc_get_ss ();;
1729 loop.temp_ss->type = GFC_SS_TEMP;
1730 loop.temp_ss->data.temp.type = base_type;
1732 if (expr->ts.type == BT_CHARACTER)
1734 gfc_ref *char_ref = expr->ref;
1736 for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
1737 if (char_ref->type == REF_SUBSTRING)
1741 expr->ts.cl = gfc_get_charlen ();
1742 expr->ts.cl->next = char_ref->u.ss.length->next;
1743 char_ref->u.ss.length->next = expr->ts.cl;
1745 gfc_init_se (&tmp_se, NULL);
1746 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1747 gfc_array_index_type);
1748 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1749 tmp_se.expr, gfc_index_one_node);
1750 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1751 gfc_init_se (&tmp_se, NULL);
1752 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1753 gfc_array_index_type);
1754 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1756 expr->ts.cl->backend_decl = tmp;
1760 loop.temp_ss->data.temp.type
1761 = gfc_typenode_for_spec (&expr->ts);
1762 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1765 loop.temp_ss->data.temp.dimen = loop.dimen;
1766 loop.temp_ss->next = gfc_ss_terminator;
1768 /* Associate the SS with the loop. */
1769 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1771 /* Setup the scalarizing loops. */
1772 gfc_conv_loop_setup (&loop);
1774 /* Pass the temporary descriptor back to the caller. */
1775 info = &loop.temp_ss->data.info;
1776 parmse->expr = info->descriptor;
1778 /* Setup the gfc_se structures. */
1779 gfc_copy_loopinfo_to_se (&lse, &loop);
1780 gfc_copy_loopinfo_to_se (&rse, &loop);
1783 lse.ss = loop.temp_ss;
1784 gfc_mark_ss_chain_used (rss, 1);
1785 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1787 /* Start the scalarized loop body. */
1788 gfc_start_scalarized_body (&loop, &body);
1790 /* Translate the expression. */
1791 gfc_conv_expr (&rse, expr);
1793 gfc_conv_tmp_array_ref (&lse);
1794 gfc_advance_se_ss_chain (&lse);
1796 if (intent != INTENT_OUT)
1798 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1799 gfc_add_expr_to_block (&body, tmp);
1800 gcc_assert (rse.ss == gfc_ss_terminator);
1801 gfc_trans_scalarizing_loops (&loop, &body);
1805 /* Make sure that the temporary declaration survives by merging
1806 all the loop declarations into the current context. */
1807 for (n = 0; n < loop.dimen; n++)
1809 gfc_merge_block_scope (&body);
1810 body = loop.code[loop.order[n]];
1812 gfc_merge_block_scope (&body);
1815 /* Add the post block after the second loop, so that any
1816 freeing of allocated memory is done at the right time. */
1817 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1819 /**********Copy the temporary back again.*********/
1821 gfc_init_se (&lse, NULL);
1822 gfc_init_se (&rse, NULL);
1824 /* Walk the argument expression. */
1825 lss = gfc_walk_expr (expr);
1826 rse.ss = loop.temp_ss;
1829 /* Initialize the scalarizer. */
1830 gfc_init_loopinfo (&loop2);
1831 gfc_add_ss_to_loop (&loop2, lss);
1833 /* Calculate the bounds of the scalarization. */
1834 gfc_conv_ss_startstride (&loop2);
1836 /* Setup the scalarizing loops. */
1837 gfc_conv_loop_setup (&loop2);
1839 gfc_copy_loopinfo_to_se (&lse, &loop2);
1840 gfc_copy_loopinfo_to_se (&rse, &loop2);
1842 gfc_mark_ss_chain_used (lss, 1);
1843 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1845 /* Declare the variable to hold the temporary offset and start the
1846 scalarized loop body. */
1847 offset = gfc_create_var (gfc_array_index_type, NULL);
1848 gfc_start_scalarized_body (&loop2, &body);
1850 /* Build the offsets for the temporary from the loop variables. The
1851 temporary array has lbounds of zero and strides of one in all
1852 dimensions, so this is very simple. The offset is only computed
1853 outside the innermost loop, so the overall transfer could be
1854 optimized further. */
1855 info = &rse.ss->data.info;
1857 tmp_index = gfc_index_zero_node;
1858 for (n = info->dimen - 1; n > 0; n--)
1861 tmp = rse.loop->loopvar[n];
1862 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1863 tmp, rse.loop->from[n]);
1864 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1867 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1868 rse.loop->to[n-1], rse.loop->from[n-1]);
1869 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1870 tmp_str, gfc_index_one_node);
1872 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1876 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1877 tmp_index, rse.loop->from[0]);
1878 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1880 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1881 rse.loop->loopvar[0], offset);
1883 /* Now use the offset for the reference. */
1884 tmp = build_fold_indirect_ref (info->data);
1885 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1887 if (expr->ts.type == BT_CHARACTER)
1888 rse.string_length = expr->ts.cl->backend_decl;
1890 gfc_conv_expr (&lse, expr);
1892 gcc_assert (lse.ss == gfc_ss_terminator);
1894 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1895 gfc_add_expr_to_block (&body, tmp);
1897 /* Generate the copying loops. */
1898 gfc_trans_scalarizing_loops (&loop2, &body);
1900 /* Wrap the whole thing up by adding the second loop to the post-block
1901 and following it by the post-block of the first loop. In this way,
1902 if the temporary needs freeing, it is done after use! */
1903 if (intent != INTENT_IN)
1905 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1906 gfc_add_block_to_block (&parmse->post, &loop2.post);
1909 gfc_add_block_to_block (&parmse->post, &loop.post);
1911 gfc_cleanup_loop (&loop);
1912 gfc_cleanup_loop (&loop2);
1914 /* Pass the string length to the argument expression. */
1915 if (expr->ts.type == BT_CHARACTER)
1916 parmse->string_length = expr->ts.cl->backend_decl;
1918 /* We want either the address for the data or the address of the descriptor,
1919 depending on the mode of passing array arguments. */
1921 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1923 parmse->expr = build_fold_addr_expr (parmse->expr);
1928 /* Is true if an array reference is followed by a component or substring
1932 is_aliased_array (gfc_expr * e)
1938 for (ref = e->ref; ref; ref = ref->next)
1940 if (ref->type == REF_ARRAY
1941 && ref->u.ar.type != AR_ELEMENT)
1945 && ref->type != REF_ARRAY)
1951 /* Generate the code for argument list functions. */
1954 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
1956 tree type = NULL_TREE;
1957 /* Pass by value for g77 %VAL(arg), pass the address
1958 indirectly for %LOC, else by reference. Thus %REF
1959 is a "do-nothing" and %LOC is the same as an F95
1961 if (strncmp (name, "%VAL", 4) == 0)
1963 gfc_conv_expr (se, expr);
1964 /* %VAL converts argument to default kind. */
1965 switch (expr->ts.type)
1968 type = gfc_get_real_type (gfc_default_real_kind);
1969 se->expr = fold_convert (type, se->expr);
1972 type = gfc_get_complex_type (gfc_default_complex_kind);
1973 se->expr = fold_convert (type, se->expr);
1976 type = gfc_get_int_type (gfc_default_integer_kind);
1977 se->expr = fold_convert (type, se->expr);
1980 type = gfc_get_logical_type (gfc_default_logical_kind);
1981 se->expr = fold_convert (type, se->expr);
1983 /* This should have been resolved away. */
1984 case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED:
1985 case BT_PROCEDURE: case BT_HOLLERITH:
1986 gfc_internal_error ("Bad type in conv_arglist_function");
1990 else if (strncmp (name, "%LOC", 4) == 0)
1992 gfc_conv_expr_reference (se, expr);
1993 se->expr = gfc_build_addr_expr (NULL, se->expr);
1995 else if (strncmp (name, "%REF", 4) == 0)
1996 gfc_conv_expr_reference (se, expr);
1998 gfc_error ("Unknown argument list function at %L", &expr->where);
2002 /* Generate code for a procedure call. Note can return se->post != NULL.
2003 If se->direct_byref is set then se->expr contains the return parameter.
2004 Return nonzero, if the call has alternate specifiers. */
2007 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2008 gfc_actual_arglist * arg, tree append_args)
2010 gfc_interface_mapping mapping;
2024 gfc_formal_arglist *formal;
2025 int has_alternate_specifier = 0;
2026 bool need_interface_mapping;
2033 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2035 arglist = NULL_TREE;
2036 retargs = NULL_TREE;
2037 stringargs = NULL_TREE;
2043 if (!sym->attr.elemental)
2045 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2046 if (se->ss->useflags)
2048 gcc_assert (gfc_return_by_reference (sym)
2049 && sym->result->attr.dimension);
2050 gcc_assert (se->loop != NULL);
2052 /* Access the previously obtained result. */
2053 gfc_conv_tmp_array_ref (se);
2054 gfc_advance_se_ss_chain (se);
2058 info = &se->ss->data.info;
2063 gfc_init_block (&post);
2064 gfc_init_interface_mapping (&mapping);
2065 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2066 && sym->ts.cl->length
2067 && sym->ts.cl->length->expr_type
2069 || sym->attr.dimension);
2070 formal = sym->formal;
2071 /* Evaluate the arguments. */
2072 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2075 fsym = formal ? formal->sym : NULL;
2076 parm_kind = MISSING;
2080 if (se->ignore_optional)
2082 /* Some intrinsics have already been resolved to the correct
2086 else if (arg->label)
2088 has_alternate_specifier = 1;
2093 /* Pass a NULL pointer for an absent arg. */
2094 gfc_init_se (&parmse, NULL);
2095 parmse.expr = null_pointer_node;
2096 if (arg->missing_arg_type == BT_CHARACTER)
2097 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2100 else if (se->ss && se->ss->useflags)
2102 /* An elemental function inside a scalarized loop. */
2103 gfc_init_se (&parmse, se);
2104 gfc_conv_expr_reference (&parmse, e);
2105 parm_kind = ELEMENTAL;
2109 /* A scalar or transformational function. */
2110 gfc_init_se (&parmse, NULL);
2111 argss = gfc_walk_expr (e);
2113 if (argss == gfc_ss_terminator)
2116 if (fsym && fsym->attr.value)
2118 gfc_conv_expr (&parmse, e);
2120 else if (arg->name && arg->name[0] == '%')
2121 /* Argument list functions %VAL, %LOC and %REF are signalled
2122 through arg->name. */
2123 conv_arglist_function (&parmse, arg->expr, arg->name);
2126 gfc_conv_expr_reference (&parmse, e);
2127 if (fsym && fsym->attr.pointer
2128 && e->expr_type != EXPR_NULL)
2130 /* Scalar pointer dummy args require an extra level of
2131 indirection. The null pointer already contains
2132 this level of indirection. */
2133 parm_kind = SCALAR_POINTER;
2134 parmse.expr = build_fold_addr_expr (parmse.expr);
2140 /* If the procedure requires an explicit interface, the actual
2141 argument is passed according to the corresponding formal
2142 argument. If the corresponding formal argument is a POINTER,
2143 ALLOCATABLE or assumed shape, we do not use g77's calling
2144 convention, and pass the address of the array descriptor
2145 instead. Otherwise we use g77's calling convention. */
2148 && !(fsym->attr.pointer || fsym->attr.allocatable)
2149 && fsym->as->type != AS_ASSUMED_SHAPE;
2150 f = f || !sym->attr.always_explicit;
2152 if (e->expr_type == EXPR_VARIABLE
2153 && is_aliased_array (e))
2154 /* The actual argument is a component reference to an
2155 array of derived types. In this case, the argument
2156 is converted to a temporary, which is passed and then
2157 written back after the procedure call. */
2158 gfc_conv_aliased_arg (&parmse, e, f,
2159 fsym ? fsym->attr.intent : INTENT_INOUT);
2161 gfc_conv_array_parameter (&parmse, e, argss, f);
2163 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2164 allocated on entry, it must be deallocated. */
2165 if (fsym && fsym->attr.allocatable
2166 && fsym->attr.intent == INTENT_OUT)
2168 tmp = build_fold_indirect_ref (parmse.expr);
2169 tmp = gfc_trans_dealloc_allocated (tmp);
2170 gfc_add_expr_to_block (&se->pre, tmp);
2180 /* If an optional argument is itself an optional dummy
2181 argument, check its presence and substitute a null
2183 if (e->expr_type == EXPR_VARIABLE
2184 && e->symtree->n.sym->attr.optional
2185 && fsym->attr.optional)
2186 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2188 /* If an INTENT(OUT) dummy of derived type has a default
2189 initializer, it must be (re)initialized here. */
2190 if (fsym->attr.intent == INTENT_OUT
2191 && fsym->ts.type == BT_DERIVED
2194 gcc_assert (!fsym->attr.allocatable);
2195 tmp = gfc_trans_assignment (e, fsym->value, false);
2196 gfc_add_expr_to_block (&se->pre, tmp);
2199 /* Obtain the character length of an assumed character
2200 length procedure from the typespec. */
2201 if (fsym->ts.type == BT_CHARACTER
2202 && parmse.string_length == NULL_TREE
2203 && e->ts.type == BT_PROCEDURE
2204 && e->symtree->n.sym->ts.type == BT_CHARACTER
2205 && e->symtree->n.sym->ts.cl->length != NULL)
2207 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2208 parmse.string_length
2209 = e->symtree->n.sym->ts.cl->backend_decl;
2213 if (need_interface_mapping)
2214 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2217 gfc_add_block_to_block (&se->pre, &parmse.pre);
2218 gfc_add_block_to_block (&post, &parmse.post);
2220 /* Allocated allocatable components of derived types must be
2221 deallocated for INTENT(OUT) dummy arguments and non-variable
2222 scalars. Non-variable arrays are dealt with in trans-array.c
2223 (gfc_conv_array_parameter). */
2224 if (e && e->ts.type == BT_DERIVED
2225 && e->ts.derived->attr.alloc_comp
2226 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2228 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2231 tmp = build_fold_indirect_ref (parmse.expr);
2232 parm_rank = e->rank;
2240 case (SCALAR_POINTER):
2241 tmp = build_fold_indirect_ref (tmp);
2248 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2249 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2250 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2251 tmp, build_empty_stmt ());
2253 if (e->expr_type != EXPR_VARIABLE)
2254 /* Don't deallocate non-variables until they have been used. */
2255 gfc_add_expr_to_block (&se->post, tmp);
2258 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2259 gfc_add_expr_to_block (&se->pre, tmp);
2263 /* Character strings are passed as two parameters, a length and a
2265 if (parmse.string_length != NULL_TREE)
2266 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2268 arglist = gfc_chainon_list (arglist, parmse.expr);
2270 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2273 if (ts.type == BT_CHARACTER)
2275 if (sym->ts.cl->length == NULL)
2277 /* Assumed character length results are not allowed by 5.1.1.5 of the
2278 standard and are trapped in resolve.c; except in the case of SPREAD
2279 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2280 we take the character length of the first argument for the result.
2281 For dummies, we have to look through the formal argument list for
2282 this function and use the character length found there.*/
2283 if (!sym->attr.dummy)
2284 cl.backend_decl = TREE_VALUE (stringargs);
2287 formal = sym->ns->proc_name->formal;
2288 for (; formal; formal = formal->next)
2289 if (strcmp (formal->sym->name, sym->name) == 0)
2290 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2295 /* Calculate the length of the returned string. */
2296 gfc_init_se (&parmse, NULL);
2297 if (need_interface_mapping)
2298 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2300 gfc_conv_expr (&parmse, sym->ts.cl->length);
2301 gfc_add_block_to_block (&se->pre, &parmse.pre);
2302 gfc_add_block_to_block (&se->post, &parmse.post);
2303 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
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,
2338 /* Pass the temporary as the first argument. */
2339 tmp = info->descriptor;
2340 tmp = build_fold_addr_expr (tmp);
2341 retargs = gfc_chainon_list (retargs, tmp);
2343 else if (ts.type == BT_CHARACTER)
2345 /* Pass the string length. */
2346 type = gfc_get_character_type (ts.kind, ts.cl);
2347 type = build_pointer_type (type);
2349 /* Return an address to a char[0:len-1]* temporary for
2350 character pointers. */
2351 if (sym->attr.pointer || sym->attr.allocatable)
2353 /* Build char[0:len-1] * pstr. */
2354 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2355 build_int_cst (gfc_charlen_type_node, 1));
2356 tmp = build_range_type (gfc_array_index_type,
2357 gfc_index_zero_node, tmp);
2358 tmp = build_array_type (gfc_character1_type_node, tmp);
2359 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2361 /* Provide an address expression for the function arguments. */
2362 var = build_fold_addr_expr (var);
2365 var = gfc_conv_string_tmp (se, type, len);
2367 retargs = gfc_chainon_list (retargs, var);
2371 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2373 type = gfc_get_complex_type (ts.kind);
2374 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2375 retargs = gfc_chainon_list (retargs, var);
2378 /* Add the string length to the argument list. */
2379 if (ts.type == BT_CHARACTER)
2380 retargs = gfc_chainon_list (retargs, len);
2382 gfc_free_interface_mapping (&mapping);
2384 /* Add the return arguments. */
2385 arglist = chainon (retargs, arglist);
2387 /* Add the hidden string length parameters to the arguments. */
2388 arglist = chainon (arglist, stringargs);
2390 /* We may want to append extra arguments here. This is used e.g. for
2391 calls to libgfortran_matmul_??, which need extra information. */
2392 if (append_args != NULL_TREE)
2393 arglist = chainon (arglist, append_args);
2395 /* Generate the actual call. */
2396 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. */
2400 if (has_alternate_specifier
2401 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2403 gcc_assert (! sym->attr.dummy);
2404 TREE_TYPE (sym->backend_decl)
2405 = build_function_type (integer_type_node,
2406 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2407 se->expr = build_fold_addr_expr (sym->backend_decl);
2410 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2411 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2412 arglist, NULL_TREE);
2414 /* If we have a pointer function, but we don't want a pointer, e.g.
2417 where f is pointer valued, we have to dereference the result. */
2418 if (!se->want_pointer && !byref && sym->attr.pointer)
2419 se->expr = build_fold_indirect_ref (se->expr);
2421 /* f2c calling conventions require a scalar default real function to
2422 return a double precision result. Convert this back to default
2423 real. We only care about the cases that can happen in Fortran 77.
2425 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2426 && sym->ts.kind == gfc_default_real_kind
2427 && !sym->attr.always_explicit)
2428 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2430 /* A pure function may still have side-effects - it may modify its
2432 TREE_SIDE_EFFECTS (se->expr) = 1;
2434 if (!sym->attr.pure)
2435 TREE_SIDE_EFFECTS (se->expr) = 1;
2440 /* Add the function call to the pre chain. There is no expression. */
2441 gfc_add_expr_to_block (&se->pre, se->expr);
2442 se->expr = NULL_TREE;
2444 if (!se->direct_byref)
2446 if (sym->attr.dimension)
2448 if (flag_bounds_check)
2450 /* Check the data pointer hasn't been modified. This would
2451 happen in a function returning a pointer. */
2452 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2453 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2455 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2457 se->expr = info->descriptor;
2458 /* Bundle in the string length. */
2459 se->string_length = len;
2461 else if (sym->ts.type == BT_CHARACTER)
2463 /* Dereference for character pointer results. */
2464 if (sym->attr.pointer || sym->attr.allocatable)
2465 se->expr = build_fold_indirect_ref (var);
2469 se->string_length = len;
2473 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2474 se->expr = build_fold_indirect_ref (var);
2479 /* Follow the function call with the argument post block. */
2481 gfc_add_block_to_block (&se->pre, &post);
2483 gfc_add_block_to_block (&se->post, &post);
2485 return has_alternate_specifier;
2489 /* Generate code to copy a string. */
2492 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2493 tree slength, tree src)
2495 tree tmp, dlen, slen;
2503 stmtblock_t tempblock;
2505 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2506 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2508 /* Deal with single character specially. */
2509 dsc = gfc_to_single_character (dlen, dest);
2510 ssc = gfc_to_single_character (slen, src);
2511 if (dsc != NULL_TREE && ssc != NULL_TREE)
2513 gfc_add_modify_expr (block, dsc, ssc);
2517 /* Do nothing if the destination length is zero. */
2518 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2519 build_int_cst (gfc_charlen_type_node, 0));
2521 /* The following code was previously in _gfortran_copy_string:
2523 // The two strings may overlap so we use memmove.
2525 copy_string (GFC_INTEGER_4 destlen, char * dest,
2526 GFC_INTEGER_4 srclen, const char * src)
2528 if (srclen >= destlen)
2530 // This will truncate if too long.
2531 memmove (dest, src, destlen);
2535 memmove (dest, src, srclen);
2537 memset (&dest[srclen], ' ', destlen - srclen);
2541 We're now doing it here for better optimization, but the logic
2544 /* Truncate string if source is too long. */
2545 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2546 tmp2 = gfc_chainon_list (NULL_TREE, dest);
2547 tmp2 = gfc_chainon_list (tmp2, src);
2548 tmp2 = gfc_chainon_list (tmp2, dlen);
2549 tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
2551 /* Else copy and pad with spaces. */
2552 tmp3 = gfc_chainon_list (NULL_TREE, dest);
2553 tmp3 = gfc_chainon_list (tmp3, src);
2554 tmp3 = gfc_chainon_list (tmp3, slen);
2555 tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
2557 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2558 fold_convert (pchar_type_node, slen));
2559 tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
2560 tmp4 = gfc_chainon_list (tmp4, build_int_cst
2561 (gfc_get_int_type (gfc_c_int_kind),
2562 lang_hooks.to_target_charset (' ')));
2563 tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2565 tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
2567 gfc_init_block (&tempblock);
2568 gfc_add_expr_to_block (&tempblock, tmp3);
2569 gfc_add_expr_to_block (&tempblock, tmp4);
2570 tmp3 = gfc_finish_block (&tempblock);
2572 /* The whole copy_string function is there. */
2573 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2574 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2575 gfc_add_expr_to_block (block, tmp);
2579 /* Translate a statement function.
2580 The value of a statement function reference is obtained by evaluating the
2581 expression using the values of the actual arguments for the values of the
2582 corresponding dummy arguments. */
2585 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2589 gfc_formal_arglist *fargs;
2590 gfc_actual_arglist *args;
2593 gfc_saved_var *saved_vars;
2599 sym = expr->symtree->n.sym;
2600 args = expr->value.function.actual;
2601 gfc_init_se (&lse, NULL);
2602 gfc_init_se (&rse, NULL);
2605 for (fargs = sym->formal; fargs; fargs = fargs->next)
2607 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2608 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2610 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2612 /* Each dummy shall be specified, explicitly or implicitly, to be
2614 gcc_assert (fargs->sym->attr.dimension == 0);
2617 /* Create a temporary to hold the value. */
2618 type = gfc_typenode_for_spec (&fsym->ts);
2619 temp_vars[n] = gfc_create_var (type, fsym->name);
2621 if (fsym->ts.type == BT_CHARACTER)
2623 /* Copy string arguments. */
2626 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2627 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2629 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2630 tmp = gfc_build_addr_expr (build_pointer_type (type),
2633 gfc_conv_expr (&rse, args->expr);
2634 gfc_conv_string_parameter (&rse);
2635 gfc_add_block_to_block (&se->pre, &lse.pre);
2636 gfc_add_block_to_block (&se->pre, &rse.pre);
2638 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2640 gfc_add_block_to_block (&se->pre, &lse.post);
2641 gfc_add_block_to_block (&se->pre, &rse.post);
2645 /* For everything else, just evaluate the expression. */
2646 gfc_conv_expr (&lse, args->expr);
2648 gfc_add_block_to_block (&se->pre, &lse.pre);
2649 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2650 gfc_add_block_to_block (&se->pre, &lse.post);
2656 /* Use the temporary variables in place of the real ones. */
2657 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2658 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2660 gfc_conv_expr (se, sym->value);
2662 if (sym->ts.type == BT_CHARACTER)
2664 gfc_conv_const_charlen (sym->ts.cl);
2666 /* Force the expression to the correct length. */
2667 if (!INTEGER_CST_P (se->string_length)
2668 || tree_int_cst_lt (se->string_length,
2669 sym->ts.cl->backend_decl))
2671 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2672 tmp = gfc_create_var (type, sym->name);
2673 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2674 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2675 se->string_length, se->expr);
2678 se->string_length = sym->ts.cl->backend_decl;
2681 /* Restore the original variables. */
2682 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2683 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2684 gfc_free (saved_vars);
2688 /* Translate a function expression. */
2691 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2695 if (expr->value.function.isym)
2697 gfc_conv_intrinsic_function (se, expr);
2701 /* We distinguish statement functions from general functions to improve
2702 runtime performance. */
2703 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2705 gfc_conv_statement_function (se, expr);
2709 /* expr.value.function.esym is the resolved (specific) function symbol for
2710 most functions. However this isn't set for dummy procedures. */
2711 sym = expr->value.function.esym;
2713 sym = expr->symtree->n.sym;
2714 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2719 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2721 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2722 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2724 gfc_conv_tmp_array_ref (se);
2725 gfc_advance_se_ss_chain (se);
2729 /* Build a static initializer. EXPR is the expression for the initial value.
2730 The other parameters describe the variable of the component being
2731 initialized. EXPR may be null. */
2734 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2735 bool array, bool pointer)
2739 if (!(expr || pointer))
2744 /* Arrays need special handling. */
2746 return gfc_build_null_descriptor (type);
2748 return gfc_conv_array_initializer (type, expr);
2751 return fold_convert (type, null_pointer_node);
2757 gfc_init_se (&se, NULL);
2758 gfc_conv_structure (&se, expr, 1);
2762 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2765 gfc_init_se (&se, NULL);
2766 gfc_conv_constant (&se, expr);
2773 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2785 gfc_start_block (&block);
2787 /* Initialize the scalarizer. */
2788 gfc_init_loopinfo (&loop);
2790 gfc_init_se (&lse, NULL);
2791 gfc_init_se (&rse, NULL);
2794 rss = gfc_walk_expr (expr);
2795 if (rss == gfc_ss_terminator)
2797 /* The rhs is scalar. Add a ss for the expression. */
2798 rss = gfc_get_ss ();
2799 rss->next = gfc_ss_terminator;
2800 rss->type = GFC_SS_SCALAR;
2804 /* Create a SS for the destination. */
2805 lss = gfc_get_ss ();
2806 lss->type = GFC_SS_COMPONENT;
2808 lss->shape = gfc_get_shape (cm->as->rank);
2809 lss->next = gfc_ss_terminator;
2810 lss->data.info.dimen = cm->as->rank;
2811 lss->data.info.descriptor = dest;
2812 lss->data.info.data = gfc_conv_array_data (dest);
2813 lss->data.info.offset = gfc_conv_array_offset (dest);
2814 for (n = 0; n < cm->as->rank; n++)
2816 lss->data.info.dim[n] = n;
2817 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2818 lss->data.info.stride[n] = gfc_index_one_node;
2820 mpz_init (lss->shape[n]);
2821 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2822 cm->as->lower[n]->value.integer);
2823 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2826 /* Associate the SS with the loop. */
2827 gfc_add_ss_to_loop (&loop, lss);
2828 gfc_add_ss_to_loop (&loop, rss);
2830 /* Calculate the bounds of the scalarization. */
2831 gfc_conv_ss_startstride (&loop);
2833 /* Setup the scalarizing loops. */
2834 gfc_conv_loop_setup (&loop);
2836 /* Setup the gfc_se structures. */
2837 gfc_copy_loopinfo_to_se (&lse, &loop);
2838 gfc_copy_loopinfo_to_se (&rse, &loop);
2841 gfc_mark_ss_chain_used (rss, 1);
2843 gfc_mark_ss_chain_used (lss, 1);
2845 /* Start the scalarized loop body. */
2846 gfc_start_scalarized_body (&loop, &body);
2848 gfc_conv_tmp_array_ref (&lse);
2849 if (cm->ts.type == BT_CHARACTER)
2850 lse.string_length = cm->ts.cl->backend_decl;
2852 gfc_conv_expr (&rse, expr);
2854 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2855 gfc_add_expr_to_block (&body, tmp);
2857 gcc_assert (rse.ss == gfc_ss_terminator);
2859 /* Generate the copying loops. */
2860 gfc_trans_scalarizing_loops (&loop, &body);
2862 /* Wrap the whole thing up. */
2863 gfc_add_block_to_block (&block, &loop.pre);
2864 gfc_add_block_to_block (&block, &loop.post);
2866 for (n = 0; n < cm->as->rank; n++)
2867 mpz_clear (lss->shape[n]);
2868 gfc_free (lss->shape);
2870 gfc_cleanup_loop (&loop);
2872 return gfc_finish_block (&block);
2876 /* Assign a single component of a derived type constructor. */
2879 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2889 gfc_start_block (&block);
2893 gfc_init_se (&se, NULL);
2894 /* Pointer component. */
2897 /* Array pointer. */
2898 if (expr->expr_type == EXPR_NULL)
2899 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2902 rss = gfc_walk_expr (expr);
2903 se.direct_byref = 1;
2905 gfc_conv_expr_descriptor (&se, expr, rss);
2906 gfc_add_block_to_block (&block, &se.pre);
2907 gfc_add_block_to_block (&block, &se.post);
2912 /* Scalar pointers. */
2913 se.want_pointer = 1;
2914 gfc_conv_expr (&se, expr);
2915 gfc_add_block_to_block (&block, &se.pre);
2916 gfc_add_modify_expr (&block, dest,
2917 fold_convert (TREE_TYPE (dest), se.expr));
2918 gfc_add_block_to_block (&block, &se.post);
2921 else if (cm->dimension)
2923 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2924 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2925 else if (cm->allocatable)
2929 gfc_init_se (&se, NULL);
2931 rss = gfc_walk_expr (expr);
2932 se.want_pointer = 0;
2933 gfc_conv_expr_descriptor (&se, expr, rss);
2934 gfc_add_block_to_block (&block, &se.pre);
2936 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2937 gfc_add_modify_expr (&block, dest, tmp);
2939 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2940 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2943 tmp = gfc_duplicate_allocatable (dest, se.expr,
2944 TREE_TYPE(cm->backend_decl),
2947 gfc_add_expr_to_block (&block, tmp);
2949 gfc_add_block_to_block (&block, &se.post);
2950 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2952 /* Shift the lbound and ubound of temporaries to being unity, rather
2953 than zero, based. Calculate the offset for all cases. */
2954 offset = gfc_conv_descriptor_offset (dest);
2955 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2956 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2957 for (n = 0; n < expr->rank; n++)
2959 if (expr->expr_type != EXPR_VARIABLE
2960 && expr->expr_type != EXPR_CONSTANT)
2962 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2963 gfc_add_modify_expr (&block, tmp,
2964 fold_build2 (PLUS_EXPR,
2965 gfc_array_index_type,
2966 tmp, gfc_index_one_node));
2967 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2968 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2970 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2971 gfc_conv_descriptor_lbound (dest,
2973 gfc_conv_descriptor_stride (dest,
2975 gfc_add_modify_expr (&block, tmp2, tmp);
2976 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2977 gfc_add_modify_expr (&block, offset, tmp);
2982 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2983 gfc_add_expr_to_block (&block, tmp);
2986 else if (expr->ts.type == BT_DERIVED)
2988 if (expr->expr_type != EXPR_STRUCTURE)
2990 gfc_init_se (&se, NULL);
2991 gfc_conv_expr (&se, expr);
2992 gfc_add_modify_expr (&block, dest,
2993 fold_convert (TREE_TYPE (dest), se.expr));
2997 /* Nested constructors. */
2998 tmp = gfc_trans_structure_assign (dest, expr);
2999 gfc_add_expr_to_block (&block, tmp);
3004 /* Scalar component. */
3005 gfc_init_se (&se, NULL);
3006 gfc_init_se (&lse, NULL);
3008 gfc_conv_expr (&se, expr);
3009 if (cm->ts.type == BT_CHARACTER)
3010 lse.string_length = cm->ts.cl->backend_decl;
3012 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3013 gfc_add_expr_to_block (&block, tmp);
3015 return gfc_finish_block (&block);
3018 /* Assign a derived type constructor to a variable. */
3021 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3029 gfc_start_block (&block);
3030 cm = expr->ts.derived->components;
3031 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3033 /* Skip absent members in default initializers. */
3037 field = cm->backend_decl;
3038 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3039 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3040 gfc_add_expr_to_block (&block, tmp);
3042 return gfc_finish_block (&block);
3045 /* Build an expression for a constructor. If init is nonzero then
3046 this is part of a static variable initializer. */
3049 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3056 VEC(constructor_elt,gc) *v = NULL;
3058 gcc_assert (se->ss == NULL);
3059 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3060 type = gfc_typenode_for_spec (&expr->ts);
3064 /* Create a temporary variable and fill it in. */
3065 se->expr = gfc_create_var (type, expr->ts.derived->name);
3066 tmp = gfc_trans_structure_assign (se->expr, expr);
3067 gfc_add_expr_to_block (&se->pre, tmp);
3071 cm = expr->ts.derived->components;
3073 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3075 /* Skip absent members in default initializers and allocatable
3076 components. Although the latter have a default initializer
3077 of EXPR_NULL,... by default, the static nullify is not needed
3078 since this is done every time we come into scope. */
3079 if (!c->expr || cm->allocatable)
3082 val = gfc_conv_initializer (c->expr, &cm->ts,
3083 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3085 /* Append it to the constructor list. */
3086 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3088 se->expr = build_constructor (type, v);
3092 /* Translate a substring expression. */
3095 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3101 gcc_assert (ref->type == REF_SUBSTRING);
3103 se->expr = gfc_build_string_const(expr->value.character.length,
3104 expr->value.character.string);
3105 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3106 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3108 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3112 /* Entry point for expression translation. Evaluates a scalar quantity.
3113 EXPR is the expression to be translated, and SE is the state structure if
3114 called from within the scalarized. */
3117 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3119 if (se->ss && se->ss->expr == expr
3120 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3122 /* Substitute a scalar expression evaluated outside the scalarization
3124 se->expr = se->ss->data.scalar.expr;
3125 se->string_length = se->ss->string_length;
3126 gfc_advance_se_ss_chain (se);
3130 switch (expr->expr_type)
3133 gfc_conv_expr_op (se, expr);
3137 gfc_conv_function_expr (se, expr);
3141 gfc_conv_constant (se, expr);
3145 gfc_conv_variable (se, expr);
3149 se->expr = null_pointer_node;
3152 case EXPR_SUBSTRING:
3153 gfc_conv_substring_expr (se, expr);
3156 case EXPR_STRUCTURE:
3157 gfc_conv_structure (se, expr, 0);
3161 gfc_conv_array_constructor_expr (se, expr);
3170 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3171 of an assignment. */
3173 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3175 gfc_conv_expr (se, expr);
3176 /* All numeric lvalues should have empty post chains. If not we need to
3177 figure out a way of rewriting an lvalue so that it has no post chain. */
3178 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3181 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3182 numeric expressions. Used for scalar values where inserting cleanup code
3185 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3189 gcc_assert (expr->ts.type != BT_CHARACTER);
3190 gfc_conv_expr (se, expr);
3193 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3194 gfc_add_modify_expr (&se->pre, val, se->expr);
3196 gfc_add_block_to_block (&se->pre, &se->post);
3200 /* Helper to translate and expression and convert it to a particular type. */
3202 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3204 gfc_conv_expr_val (se, expr);
3205 se->expr = convert (type, se->expr);
3209 /* Converts an expression so that it can be passed by reference. Scalar
3213 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3217 if (se->ss && se->ss->expr == expr
3218 && se->ss->type == GFC_SS_REFERENCE)
3220 se->expr = se->ss->data.scalar.expr;
3221 se->string_length = se->ss->string_length;
3222 gfc_advance_se_ss_chain (se);
3226 if (expr->ts.type == BT_CHARACTER)
3228 gfc_conv_expr (se, expr);
3229 gfc_conv_string_parameter (se);
3233 if (expr->expr_type == EXPR_VARIABLE)
3235 se->want_pointer = 1;
3236 gfc_conv_expr (se, expr);
3239 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3240 gfc_add_modify_expr (&se->pre, var, se->expr);
3241 gfc_add_block_to_block (&se->pre, &se->post);
3247 gfc_conv_expr (se, expr);
3249 /* Create a temporary var to hold the value. */
3250 if (TREE_CONSTANT (se->expr))
3252 tree tmp = se->expr;
3253 STRIP_TYPE_NOPS (tmp);
3254 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3255 DECL_INITIAL (var) = tmp;
3256 TREE_STATIC (var) = 1;
3261 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3262 gfc_add_modify_expr (&se->pre, var, se->expr);
3264 gfc_add_block_to_block (&se->pre, &se->post);
3266 /* Take the address of that value. */
3267 se->expr = build_fold_addr_expr (var);
3272 gfc_trans_pointer_assign (gfc_code * code)
3274 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3278 /* Generate code for a pointer assignment. */
3281 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3291 gfc_start_block (&block);
3293 gfc_init_se (&lse, NULL);
3295 lss = gfc_walk_expr (expr1);
3296 rss = gfc_walk_expr (expr2);
3297 if (lss == gfc_ss_terminator)
3299 /* Scalar pointers. */
3300 lse.want_pointer = 1;
3301 gfc_conv_expr (&lse, expr1);
3302 gcc_assert (rss == gfc_ss_terminator);
3303 gfc_init_se (&rse, NULL);
3304 rse.want_pointer = 1;
3305 gfc_conv_expr (&rse, expr2);
3306 gfc_add_block_to_block (&block, &lse.pre);
3307 gfc_add_block_to_block (&block, &rse.pre);
3308 gfc_add_modify_expr (&block, lse.expr,
3309 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3310 gfc_add_block_to_block (&block, &rse.post);
3311 gfc_add_block_to_block (&block, &lse.post);
3315 /* Array pointer. */
3316 gfc_conv_expr_descriptor (&lse, expr1, lss);
3317 switch (expr2->expr_type)
3320 /* Just set the data pointer to null. */
3321 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3325 /* Assign directly to the pointer's descriptor. */
3326 lse.direct_byref = 1;
3327 gfc_conv_expr_descriptor (&lse, expr2, rss);
3331 /* Assign to a temporary descriptor and then copy that
3332 temporary to the pointer. */
3334 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3337 lse.direct_byref = 1;
3338 gfc_conv_expr_descriptor (&lse, expr2, rss);
3339 gfc_add_modify_expr (&lse.pre, desc, tmp);
3342 gfc_add_block_to_block (&block, &lse.pre);
3343 gfc_add_block_to_block (&block, &lse.post);
3345 return gfc_finish_block (&block);
3349 /* Makes sure se is suitable for passing as a function string parameter. */
3350 /* TODO: Need to check all callers fo this function. It may be abused. */
3353 gfc_conv_string_parameter (gfc_se * se)
3357 if (TREE_CODE (se->expr) == STRING_CST)
3359 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3363 type = TREE_TYPE (se->expr);
3364 if (TYPE_STRING_FLAG (type))
3366 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3367 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3370 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3371 gcc_assert (se->string_length
3372 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3376 /* Generate code for assignment of scalar variables. Includes character
3377 strings and derived types with allocatable components. */
3380 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3381 bool l_is_temp, bool r_is_var)
3387 gfc_init_block (&block);
3389 if (ts.type == BT_CHARACTER)
3391 gcc_assert (lse->string_length != NULL_TREE
3392 && rse->string_length != NULL_TREE);
3394 gfc_conv_string_parameter (lse);
3395 gfc_conv_string_parameter (rse);
3397 gfc_add_block_to_block (&block, &lse->pre);
3398 gfc_add_block_to_block (&block, &rse->pre);
3400 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3401 rse->string_length, rse->expr);
3403 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3407 /* Are the rhs and the lhs the same? */
3410 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3411 build_fold_addr_expr (lse->expr),
3412 build_fold_addr_expr (rse->expr));
3413 cond = gfc_evaluate_now (cond, &lse->pre);
3416 /* Deallocate the lhs allocated components as long as it is not
3417 the same as the rhs. */
3420 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3422 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3423 gfc_add_expr_to_block (&lse->pre, tmp);
3426 gfc_add_block_to_block (&block, &lse->pre);
3427 gfc_add_block_to_block (&block, &rse->pre);
3429 gfc_add_modify_expr (&block, lse->expr,
3430 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3432 /* Do a deep copy if the rhs is a variable, if it is not the
3436 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3437 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3438 gfc_add_expr_to_block (&block, tmp);
3443 gfc_add_block_to_block (&block, &lse->pre);
3444 gfc_add_block_to_block (&block, &rse->pre);
3446 gfc_add_modify_expr (&block, lse->expr,
3447 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3450 gfc_add_block_to_block (&block, &lse->post);
3451 gfc_add_block_to_block (&block, &rse->post);
3453 return gfc_finish_block (&block);
3457 /* Try to translate array(:) = func (...), where func is a transformational
3458 array function, without using a temporary. Returns NULL is this isn't the
3462 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3467 bool seen_array_ref;
3469 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3470 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3473 /* Elemental functions don't need a temporary anyway. */
3474 if (expr2->value.function.esym != NULL
3475 && expr2->value.function.esym->attr.elemental)
3478 /* Fail if EXPR1 can't be expressed as a descriptor. */
3479 if (gfc_ref_needs_temporary_p (expr1->ref))
3482 /* Functions returning pointers need temporaries. */
3483 if (expr2->symtree->n.sym->attr.pointer
3484 || expr2->symtree->n.sym->attr.allocatable)
3487 /* Character array functions need temporaries unless the
3488 character lengths are the same. */
3489 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3491 if (expr1->ts.cl->length == NULL
3492 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3495 if (expr2->ts.cl->length == NULL
3496 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3499 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3500 expr2->ts.cl->length->value.integer) != 0)
3504 /* Check that no LHS component references appear during an array
3505 reference. This is needed because we do not have the means to
3506 span any arbitrary stride with an array descriptor. This check
3507 is not needed for the rhs because the function result has to be
3509 seen_array_ref = false;
3510 for (ref = expr1->ref; ref; ref = ref->next)
3512 if (ref->type == REF_ARRAY)
3513 seen_array_ref= true;
3514 else if (ref->type == REF_COMPONENT && seen_array_ref)
3518 /* Check for a dependency. */
3519 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3520 expr2->value.function.esym,
3521 expr2->value.function.actual))
3524 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3526 gcc_assert (expr2->value.function.isym
3527 || (gfc_return_by_reference (expr2->value.function.esym)
3528 && expr2->value.function.esym->result->attr.dimension));
3530 ss = gfc_walk_expr (expr1);
3531 gcc_assert (ss != gfc_ss_terminator);
3532 gfc_init_se (&se, NULL);
3533 gfc_start_block (&se.pre);
3534 se.want_pointer = 1;
3536 gfc_conv_array_parameter (&se, expr1, ss, 0);
3538 se.direct_byref = 1;
3539 se.ss = gfc_walk_expr (expr2);
3540 gcc_assert (se.ss != gfc_ss_terminator);
3541 gfc_conv_function_expr (&se, expr2);
3542 gfc_add_block_to_block (&se.pre, &se.post);
3544 return gfc_finish_block (&se.pre);
3547 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3550 is_zero_initializer_p (gfc_expr * expr)
3552 if (expr->expr_type != EXPR_CONSTANT)
3554 /* We ignore Hollerith constants for the time being. */
3558 switch (expr->ts.type)
3561 return mpz_cmp_si (expr->value.integer, 0) == 0;
3564 return mpfr_zero_p (expr->value.real)
3565 && MPFR_SIGN (expr->value.real) >= 0;
3568 return expr->value.logical == 0;
3571 return mpfr_zero_p (expr->value.complex.r)
3572 && MPFR_SIGN (expr->value.complex.r) >= 0
3573 && mpfr_zero_p (expr->value.complex.i)
3574 && MPFR_SIGN (expr->value.complex.i) >= 0;
3582 /* Try to efficiently translate array(:) = 0. Return NULL if this
3586 gfc_trans_zero_assign (gfc_expr * expr)
3588 tree dest, len, type;
3592 sym = expr->symtree->n.sym;
3593 dest = gfc_get_symbol_decl (sym);
3595 type = TREE_TYPE (dest);
3596 if (POINTER_TYPE_P (type))
3597 type = TREE_TYPE (type);
3598 if (!GFC_ARRAY_TYPE_P (type))
3601 /* Determine the length of the array. */
3602 len = GFC_TYPE_ARRAY_SIZE (type);
3603 if (!len || TREE_CODE (len) != INTEGER_CST)
3606 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3607 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
3609 /* Convert arguments to the correct types. */
3610 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3611 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3613 dest = fold_convert (pvoid_type_node, dest);
3614 len = fold_convert (size_type_node, len);
3616 /* Construct call to __builtin_memset. */
3617 args = build_tree_list (NULL_TREE, len);
3618 args = tree_cons (NULL_TREE, integer_zero_node, args);
3619 args = tree_cons (NULL_TREE, dest, args);
3620 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], args);
3621 return fold_convert (void_type_node, tmp);
3625 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3626 that constructs the call to __builtin_memcpy. */
3629 gfc_build_memcpy_call (tree dst, tree src, tree len)
3633 /* Convert arguments to the correct types. */
3634 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3635 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3637 dst = fold_convert (pvoid_type_node, dst);
3639 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3640 src = gfc_build_addr_expr (pvoid_type_node, src);
3642 src = fold_convert (pvoid_type_node, src);
3644 len = fold_convert (size_type_node, len);
3646 /* Construct call to __builtin_memcpy. */
3647 args = build_tree_list (NULL_TREE, len);
3648 args = tree_cons (NULL_TREE, src, args);
3649 args = tree_cons (NULL_TREE, dst, args);
3650 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY], args);
3651 return fold_convert (void_type_node, tmp);
3655 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3656 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3657 source/rhs, both are gfc_full_array_ref_p which have been checked for
3661 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3663 tree dst, dlen, dtype;
3664 tree src, slen, stype;
3666 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3667 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3669 dtype = TREE_TYPE (dst);
3670 if (POINTER_TYPE_P (dtype))
3671 dtype = TREE_TYPE (dtype);
3672 stype = TREE_TYPE (src);
3673 if (POINTER_TYPE_P (stype))
3674 stype = TREE_TYPE (stype);
3676 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3679 /* Determine the lengths of the arrays. */
3680 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3681 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3683 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3684 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3686 slen = GFC_TYPE_ARRAY_SIZE (stype);
3687 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3689 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3690 TYPE_SIZE_UNIT (gfc_get_element_type (stype)));
3692 /* Sanity check that they are the same. This should always be
3693 the case, as we should already have checked for conformance. */
3694 if (!tree_int_cst_equal (slen, dlen))
3697 return gfc_build_memcpy_call (dst, src, dlen);
3701 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3702 this can't be done. EXPR1 is the destination/lhs for which
3703 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3706 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3708 unsigned HOST_WIDE_INT nelem;
3713 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3717 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3718 dtype = TREE_TYPE (dst);
3719 if (POINTER_TYPE_P (dtype))
3720 dtype = TREE_TYPE (dtype);
3721 if (!GFC_ARRAY_TYPE_P (dtype))
3724 /* Determine the lengths of the array. */
3725 len = GFC_TYPE_ARRAY_SIZE (dtype);
3726 if (!len || TREE_CODE (len) != INTEGER_CST)
3729 /* Confirm that the constructor is the same size. */
3730 if (compare_tree_int (len, nelem) != 0)
3733 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3734 TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3736 stype = gfc_typenode_for_spec (&expr2->ts);
3737 src = gfc_build_constant_array_constructor (expr2, stype);
3739 stype = TREE_TYPE (src);
3740 if (POINTER_TYPE_P (stype))
3741 stype = TREE_TYPE (stype);
3743 return gfc_build_memcpy_call (dst, src, len);
3747 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3748 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3751 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3756 gfc_ss *lss_section;
3764 /* Assignment of the form lhs = rhs. */
3765 gfc_start_block (&block);
3767 gfc_init_se (&lse, NULL);
3768 gfc_init_se (&rse, NULL);
3771 lss = gfc_walk_expr (expr1);
3773 if (lss != gfc_ss_terminator)
3775 /* The assignment needs scalarization. */
3778 /* Find a non-scalar SS from the lhs. */
3779 while (lss_section != gfc_ss_terminator
3780 && lss_section->type != GFC_SS_SECTION)
3781 lss_section = lss_section->next;
3783 gcc_assert (lss_section != gfc_ss_terminator);
3785 /* Initialize the scalarizer. */
3786 gfc_init_loopinfo (&loop);
3789 rss = gfc_walk_expr (expr2);
3790 if (rss == gfc_ss_terminator)
3792 /* The rhs is scalar. Add a ss for the expression. */
3793 rss = gfc_get_ss ();
3794 rss->next = gfc_ss_terminator;
3795 rss->type = GFC_SS_SCALAR;
3798 /* Associate the SS with the loop. */
3799 gfc_add_ss_to_loop (&loop, lss);
3800 gfc_add_ss_to_loop (&loop, rss);
3802 /* Calculate the bounds of the scalarization. */
3803 gfc_conv_ss_startstride (&loop);
3804 /* Resolve any data dependencies in the statement. */
3805 gfc_conv_resolve_dependencies (&loop, lss, rss);
3806 /* Setup the scalarizing loops. */
3807 gfc_conv_loop_setup (&loop);
3809 /* Setup the gfc_se structures. */
3810 gfc_copy_loopinfo_to_se (&lse, &loop);
3811 gfc_copy_loopinfo_to_se (&rse, &loop);
3814 gfc_mark_ss_chain_used (rss, 1);
3815 if (loop.temp_ss == NULL)
3818 gfc_mark_ss_chain_used (lss, 1);
3822 lse.ss = loop.temp_ss;
3823 gfc_mark_ss_chain_used (lss, 3);
3824 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3827 /* Start the scalarized loop body. */
3828 gfc_start_scalarized_body (&loop, &body);
3831 gfc_init_block (&body);
3833 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3835 /* Translate the expression. */
3836 gfc_conv_expr (&rse, expr2);
3840 gfc_conv_tmp_array_ref (&lse);
3841 gfc_advance_se_ss_chain (&lse);
3844 gfc_conv_expr (&lse, expr1);
3846 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3847 l_is_temp || init_flag,
3848 expr2->expr_type == EXPR_VARIABLE);
3849 gfc_add_expr_to_block (&body, tmp);
3851 if (lss == gfc_ss_terminator)
3853 /* Use the scalar assignment as is. */
3854 gfc_add_block_to_block (&block, &body);
3858 gcc_assert (lse.ss == gfc_ss_terminator
3859 && rse.ss == gfc_ss_terminator);
3863 gfc_trans_scalarized_loop_boundary (&loop, &body);
3865 /* We need to copy the temporary to the actual lhs. */
3866 gfc_init_se (&lse, NULL);
3867 gfc_init_se (&rse, NULL);
3868 gfc_copy_loopinfo_to_se (&lse, &loop);
3869 gfc_copy_loopinfo_to_se (&rse, &loop);
3871 rse.ss = loop.temp_ss;
3874 gfc_conv_tmp_array_ref (&rse);
3875 gfc_advance_se_ss_chain (&rse);
3876 gfc_conv_expr (&lse, expr1);
3878 gcc_assert (lse.ss == gfc_ss_terminator
3879 && rse.ss == gfc_ss_terminator);
3881 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3883 gfc_add_expr_to_block (&body, tmp);
3886 /* Generate the copying loops. */
3887 gfc_trans_scalarizing_loops (&loop, &body);
3889 /* Wrap the whole thing up. */
3890 gfc_add_block_to_block (&block, &loop.pre);
3891 gfc_add_block_to_block (&block, &loop.post);
3893 gfc_cleanup_loop (&loop);
3896 return gfc_finish_block (&block);
3900 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3903 copyable_array_p (gfc_expr * expr)
3905 /* First check it's an array. */
3906 if (expr->rank < 1 || !expr->ref)
3909 /* Next check that it's of a simple enough type. */
3910 switch (expr->ts.type)
3922 return !expr->ts.derived->attr.alloc_comp;
3931 /* Translate an assignment. */
3934 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3938 /* Special case a single function returning an array. */
3939 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3941 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3946 /* Special case assigning an array to zero. */
3947 if (expr1->expr_type == EXPR_VARIABLE
3950 && gfc_full_array_ref_p (expr1->ref)
3951 && is_zero_initializer_p (expr2))
3953 tmp = gfc_trans_zero_assign (expr1);
3958 /* Special case copying one array to another. */
3959 if (expr1->expr_type == EXPR_VARIABLE
3960 && copyable_array_p (expr1)
3961 && gfc_full_array_ref_p (expr1->ref)
3962 && expr2->expr_type == EXPR_VARIABLE
3963 && copyable_array_p (expr2)
3964 && gfc_full_array_ref_p (expr2->ref)
3965 && gfc_compare_types (&expr1->ts, &expr2->ts)
3966 && !gfc_check_dependency (expr1, expr2, 0))
3968 tmp = gfc_trans_array_copy (expr1, expr2);
3973 /* Special case initializing an array from a constant array constructor. */
3974 if (expr1->expr_type == EXPR_VARIABLE
3975 && copyable_array_p (expr1)
3976 && gfc_full_array_ref_p (expr1->ref)
3977 && expr2->expr_type == EXPR_ARRAY
3978 && gfc_compare_types (&expr1->ts, &expr2->ts))
3980 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
3985 /* Fallback to the scalarizer to generate explicit loops. */
3986 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
3990 gfc_trans_init_assign (gfc_code * code)
3992 return gfc_trans_assignment (code->expr, code->expr2, true);
3996 gfc_trans_assign (gfc_code * code)
3998 return gfc_trans_assignment (code->expr, code->expr2, false);