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"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify_expr (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 return build2 (NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
145 /* Get the character length of an expression, looking through gfc_refs
149 gfc_get_expr_charlen (gfc_expr *e)
154 gcc_assert (e->expr_type == EXPR_VARIABLE
155 && e->ts.type == BT_CHARACTER);
157 length = NULL; /* To silence compiler warning. */
159 /* First candidate: if the variable is of type CHARACTER, the
160 expression's length could be the length of the character
162 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
163 length = e->symtree->n.sym->ts.cl->backend_decl;
165 /* Look through the reference chain for component references. */
166 for (r = e->ref; r; r = r->next)
171 if (r->u.c.component->ts.type == BT_CHARACTER)
172 length = r->u.c.component->ts.cl->backend_decl;
180 /* We should never got substring references here. These will be
181 broken down by the scalarizer. */
186 gcc_assert (length != NULL);
192 /* Generate code to initialize a string length variable. Returns the
196 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
201 gfc_init_se (&se, NULL);
202 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
203 gfc_add_block_to_block (pblock, &se.pre);
205 tmp = cl->backend_decl;
206 gfc_add_modify_expr (pblock, tmp, se.expr);
211 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
219 type = gfc_get_character_type (kind, ref->u.ss.length);
220 type = build_pointer_type (type);
223 gfc_init_se (&start, se);
224 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
225 gfc_add_block_to_block (&se->pre, &start.pre);
227 if (integer_onep (start.expr))
228 gfc_conv_string_parameter (se);
231 /* Change the start of the string. */
232 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
235 tmp = build_fold_indirect_ref (se->expr);
236 tmp = gfc_build_array_ref (tmp, start.expr);
237 se->expr = gfc_build_addr_expr (type, tmp);
240 /* Length = end + 1 - start. */
241 gfc_init_se (&end, se);
242 if (ref->u.ss.end == NULL)
243 end.expr = se->string_length;
246 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
247 gfc_add_block_to_block (&se->pre, &end.pre);
249 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
250 build_int_cst (gfc_charlen_type_node, 1),
252 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
253 se->string_length = tmp;
257 /* Convert a derived type component reference. */
260 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
267 c = ref->u.c.component;
269 gcc_assert (c->backend_decl);
271 field = c->backend_decl;
272 gcc_assert (TREE_CODE (field) == FIELD_DECL);
274 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
278 if (c->ts.type == BT_CHARACTER)
280 tmp = c->ts.cl->backend_decl;
281 /* Components must always be constant length. */
282 gcc_assert (tmp && INTEGER_CST_P (tmp));
283 se->string_length = tmp;
286 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
287 se->expr = build_fold_indirect_ref (se->expr);
291 /* Return the contents of a variable. Also handles reference/pointer
292 variables (all Fortran pointer references are implicit). */
295 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
302 bool alternate_entry;
305 sym = expr->symtree->n.sym;
308 /* Check that something hasn't gone horribly wrong. */
309 gcc_assert (se->ss != gfc_ss_terminator);
310 gcc_assert (se->ss->expr == expr);
312 /* A scalarized term. We already know the descriptor. */
313 se->expr = se->ss->data.info.descriptor;
314 se->string_length = se->ss->string_length;
315 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
316 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
321 tree se_expr = NULL_TREE;
323 se->expr = gfc_get_symbol_decl (sym);
325 /* Deal with references to a parent results or entries by storing
326 the current_function_decl and moving to the parent_decl. */
327 return_value = sym->attr.function && sym->result == sym;
328 alternate_entry = sym->attr.function && sym->attr.entry
329 && sym->result == sym;
330 entry_master = sym->attr.result
331 && sym->ns->proc_name->attr.entry_master
332 && !gfc_return_by_reference (sym->ns->proc_name);
333 parent_decl = DECL_CONTEXT (current_function_decl);
335 if ((se->expr == parent_decl && return_value)
336 || (sym->ns && sym->ns->proc_name
337 && sym->ns->proc_name->backend_decl == parent_decl
338 && (alternate_entry || entry_master)))
343 /* Special case for assigning the return value of a function.
344 Self recursive functions must have an explicit return value. */
345 if (return_value && (se->expr == current_function_decl || parent_flag))
346 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
348 /* Similarly for alternate entry points. */
349 else if (alternate_entry
350 && (sym->ns->proc_name->backend_decl == current_function_decl
353 gfc_entry_list *el = NULL;
355 for (el = sym->ns->entries; el; el = el->next)
358 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
363 else if (entry_master
364 && (sym->ns->proc_name->backend_decl == current_function_decl
366 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
371 /* Procedure actual arguments. */
372 else if (sym->attr.flavor == FL_PROCEDURE
373 && se->expr != current_function_decl)
375 gcc_assert (se->want_pointer);
376 if (!sym->attr.dummy)
378 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
379 se->expr = build_fold_addr_expr (se->expr);
385 /* Dereference the expression, where needed. Since characters
386 are entirely different from other types, they are treated
388 if (sym->ts.type == BT_CHARACTER)
390 /* Dereference character pointer dummy arguments
392 if ((sym->attr.pointer || sym->attr.allocatable)
394 || sym->attr.function
395 || sym->attr.result))
396 se->expr = build_fold_indirect_ref (se->expr);
400 /* Dereference non-character scalar dummy arguments. */
401 if (sym->attr.dummy && !sym->attr.dimension)
402 se->expr = build_fold_indirect_ref (se->expr);
404 /* Dereference scalar hidden result. */
405 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
406 && (sym->attr.function || sym->attr.result)
407 && !sym->attr.dimension && !sym->attr.pointer)
408 se->expr = build_fold_indirect_ref (se->expr);
410 /* Dereference non-character pointer variables.
411 These must be dummies, results, or scalars. */
412 if ((sym->attr.pointer || sym->attr.allocatable)
414 || sym->attr.function
416 || !sym->attr.dimension))
417 se->expr = build_fold_indirect_ref (se->expr);
423 /* For character variables, also get the length. */
424 if (sym->ts.type == BT_CHARACTER)
426 /* If the character length of an entry isn't set, get the length from
427 the master function instead. */
428 if (sym->attr.entry && !sym->ts.cl->backend_decl)
429 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
431 se->string_length = sym->ts.cl->backend_decl;
432 gcc_assert (se->string_length);
440 /* Return the descriptor if that's what we want and this is an array
441 section reference. */
442 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
444 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
445 /* Return the descriptor for array pointers and allocations. */
447 && ref->next == NULL && (se->descriptor_only))
450 gfc_conv_array_ref (se, &ref->u.ar);
451 /* Return a pointer to an element. */
455 gfc_conv_component_ref (se, ref);
459 gfc_conv_substring (se, ref, expr->ts.kind);
468 /* Pointer assignment, allocation or pass by reference. Arrays are handled
470 if (se->want_pointer)
472 if (expr->ts.type == BT_CHARACTER)
473 gfc_conv_string_parameter (se);
475 se->expr = build_fold_addr_expr (se->expr);
480 /* Unary ops are easy... Or they would be if ! was a valid op. */
483 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
488 gcc_assert (expr->ts.type != BT_CHARACTER);
489 /* Initialize the operand. */
490 gfc_init_se (&operand, se);
491 gfc_conv_expr_val (&operand, expr->value.op.op1);
492 gfc_add_block_to_block (&se->pre, &operand.pre);
494 type = gfc_typenode_for_spec (&expr->ts);
496 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
497 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
498 All other unary operators have an equivalent GIMPLE unary operator. */
499 if (code == TRUTH_NOT_EXPR)
500 se->expr = build2 (EQ_EXPR, type, operand.expr,
501 convert (type, integer_zero_node));
503 se->expr = build1 (code, type, operand.expr);
507 /* Expand power operator to optimal multiplications when a value is raised
508 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
509 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
510 Programming", 3rd Edition, 1998. */
512 /* This code is mostly duplicated from expand_powi in the backend.
513 We establish the "optimal power tree" lookup table with the defined size.
514 The items in the table are the exponents used to calculate the index
515 exponents. Any integer n less than the value can get an "addition chain",
516 with the first node being one. */
517 #define POWI_TABLE_SIZE 256
519 /* The table is from builtins.c. */
520 static const unsigned char powi_table[POWI_TABLE_SIZE] =
522 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
523 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
524 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
525 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
526 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
527 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
528 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
529 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
530 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
531 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
532 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
533 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
534 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
535 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
536 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
537 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
538 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
539 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
540 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
541 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
542 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
543 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
544 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
545 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
546 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
547 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
548 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
549 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
550 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
551 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
552 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
553 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
556 /* If n is larger than lookup table's max index, we use the "window
558 #define POWI_WINDOW_SIZE 3
560 /* Recursive function to expand the power operator. The temporary
561 values are put in tmpvar. The function returns tmpvar[1] ** n. */
563 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
570 if (n < POWI_TABLE_SIZE)
575 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
576 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
580 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
581 op0 = gfc_conv_powi (se, n - digit, tmpvar);
582 op1 = gfc_conv_powi (se, digit, tmpvar);
586 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
590 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
591 tmp = gfc_evaluate_now (tmp, &se->pre);
593 if (n < POWI_TABLE_SIZE)
600 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
601 return 1. Else return 0 and a call to runtime library functions
602 will have to be built. */
604 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
609 tree vartmp[POWI_TABLE_SIZE];
613 type = TREE_TYPE (lhs);
614 n = abs (TREE_INT_CST_LOW (rhs));
615 sgn = tree_int_cst_sgn (rhs);
617 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
618 && (n > 2 || n < -1))
624 se->expr = gfc_build_const (type, integer_one_node);
627 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
628 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
630 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
631 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
632 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
633 convert (TREE_TYPE (lhs), integer_one_node));
636 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
639 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
640 se->expr = build3 (COND_EXPR, type, tmp,
641 convert (type, integer_one_node),
642 convert (type, integer_zero_node));
646 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
647 tmp = build3 (COND_EXPR, type, tmp,
648 convert (type, integer_minus_one_node),
649 convert (type, integer_zero_node));
650 se->expr = build3 (COND_EXPR, type, cond,
651 convert (type, integer_one_node),
656 memset (vartmp, 0, sizeof (vartmp));
660 tmp = gfc_build_const (type, integer_one_node);
661 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
664 se->expr = gfc_conv_powi (se, n, vartmp);
670 /* Power op (**). Constant integer exponent has special handling. */
673 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
675 tree gfc_int4_type_node;
683 gfc_init_se (&lse, se);
684 gfc_conv_expr_val (&lse, expr->value.op.op1);
685 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
686 gfc_add_block_to_block (&se->pre, &lse.pre);
688 gfc_init_se (&rse, se);
689 gfc_conv_expr_val (&rse, expr->value.op.op2);
690 gfc_add_block_to_block (&se->pre, &rse.pre);
692 if (expr->value.op.op2->ts.type == BT_INTEGER
693 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
694 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
697 gfc_int4_type_node = gfc_get_int_type (4);
699 kind = expr->value.op.op1->ts.kind;
700 switch (expr->value.op.op2->ts.type)
703 ikind = expr->value.op.op2->ts.kind;
708 rse.expr = convert (gfc_int4_type_node, rse.expr);
730 if (expr->value.op.op1->ts.type == BT_INTEGER)
731 lse.expr = convert (gfc_int4_type_node, lse.expr);
756 switch (expr->value.op.op1->ts.type)
759 if (kind == 3) /* Case 16 was not handled properly above. */
761 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
765 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
769 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
781 fndecl = built_in_decls[BUILT_IN_POWF];
784 fndecl = built_in_decls[BUILT_IN_POW];
788 fndecl = built_in_decls[BUILT_IN_POWL];
799 fndecl = gfor_fndecl_math_cpowf;
802 fndecl = gfor_fndecl_math_cpow;
805 fndecl = gfor_fndecl_math_cpowl10;
808 fndecl = gfor_fndecl_math_cpowl16;
820 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
821 tmp = gfc_chainon_list (tmp, rse.expr);
822 se->expr = build_function_call_expr (fndecl, tmp);
826 /* Generate code to allocate a string temporary. */
829 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
835 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
837 if (gfc_can_put_var_on_stack (len))
839 /* Create a temporary variable to hold the result. */
840 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
841 convert (gfc_charlen_type_node, integer_one_node));
842 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
843 tmp = build_array_type (gfc_character1_type_node, tmp);
844 var = gfc_create_var (tmp, "str");
845 var = gfc_build_addr_expr (type, var);
849 /* Allocate a temporary to hold the result. */
850 var = gfc_create_var (type, "pstr");
851 args = gfc_chainon_list (NULL_TREE, len);
852 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
853 tmp = convert (type, tmp);
854 gfc_add_modify_expr (&se->pre, var, tmp);
856 /* Free the temporary afterwards. */
857 tmp = convert (pvoid_type_node, var);
858 args = gfc_chainon_list (NULL_TREE, tmp);
859 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
860 gfc_add_expr_to_block (&se->post, tmp);
867 /* Handle a string concatenation operation. A temporary will be allocated to
871 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
881 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
882 && expr->value.op.op2->ts.type == BT_CHARACTER);
884 gfc_init_se (&lse, se);
885 gfc_conv_expr (&lse, expr->value.op.op1);
886 gfc_conv_string_parameter (&lse);
887 gfc_init_se (&rse, se);
888 gfc_conv_expr (&rse, expr->value.op.op2);
889 gfc_conv_string_parameter (&rse);
891 gfc_add_block_to_block (&se->pre, &lse.pre);
892 gfc_add_block_to_block (&se->pre, &rse.pre);
894 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
895 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
896 if (len == NULL_TREE)
898 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
899 lse.string_length, rse.string_length);
902 type = build_pointer_type (type);
904 var = gfc_conv_string_tmp (se, type, len);
906 /* Do the actual concatenation. */
908 args = gfc_chainon_list (args, len);
909 args = gfc_chainon_list (args, var);
910 args = gfc_chainon_list (args, lse.string_length);
911 args = gfc_chainon_list (args, lse.expr);
912 args = gfc_chainon_list (args, rse.string_length);
913 args = gfc_chainon_list (args, rse.expr);
914 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
915 gfc_add_expr_to_block (&se->pre, tmp);
917 /* Add the cleanup for the operands. */
918 gfc_add_block_to_block (&se->pre, &rse.post);
919 gfc_add_block_to_block (&se->pre, &lse.post);
922 se->string_length = len;
925 /* Translates an op expression. Common (binary) cases are handled by this
926 function, others are passed on. Recursion is used in either case.
927 We use the fact that (op1.ts == op2.ts) (except for the power
929 Operators need no special handling for scalarized expressions as long as
930 they call gfc_conv_simple_val to get their operands.
931 Character strings get special handling. */
934 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
946 switch (expr->value.op.operator)
948 case INTRINSIC_UPLUS:
949 case INTRINSIC_PARENTHESES:
950 gfc_conv_expr (se, expr->value.op.op1);
953 case INTRINSIC_UMINUS:
954 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
958 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
965 case INTRINSIC_MINUS:
969 case INTRINSIC_TIMES:
973 case INTRINSIC_DIVIDE:
974 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
975 an integer, we must round towards zero, so we use a
977 if (expr->ts.type == BT_INTEGER)
978 code = TRUNC_DIV_EXPR;
983 case INTRINSIC_POWER:
984 gfc_conv_power_op (se, expr);
987 case INTRINSIC_CONCAT:
988 gfc_conv_concat_op (se, expr);
992 code = TRUTH_ANDIF_EXPR;
997 code = TRUTH_ORIF_EXPR;
1001 /* EQV and NEQV only work on logicals, but since we represent them
1002 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1011 case INTRINSIC_NEQV:
1041 case INTRINSIC_USER:
1042 case INTRINSIC_ASSIGN:
1043 /* These should be converted into function calls by the frontend. */
1047 fatal_error ("Unknown intrinsic op");
1051 /* The only exception to this is **, which is handled separately anyway. */
1052 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1054 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1058 gfc_init_se (&lse, se);
1059 gfc_conv_expr (&lse, expr->value.op.op1);
1060 gfc_add_block_to_block (&se->pre, &lse.pre);
1063 gfc_init_se (&rse, se);
1064 gfc_conv_expr (&rse, expr->value.op.op2);
1065 gfc_add_block_to_block (&se->pre, &rse.pre);
1069 gfc_conv_string_parameter (&lse);
1070 gfc_conv_string_parameter (&rse);
1072 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1073 rse.string_length, rse.expr);
1074 rse.expr = integer_zero_node;
1075 gfc_add_block_to_block (&lse.post, &rse.post);
1078 type = gfc_typenode_for_spec (&expr->ts);
1082 /* The result of logical ops is always boolean_type_node. */
1083 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1084 se->expr = convert (type, tmp);
1087 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1089 /* Add the post blocks. */
1090 gfc_add_block_to_block (&se->post, &rse.post);
1091 gfc_add_block_to_block (&se->post, &lse.post);
1094 /* If a string's length is one, we convert it to a single character. */
1097 gfc_to_single_character (tree len, tree str)
1099 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1101 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1102 && TREE_INT_CST_HIGH (len) == 0)
1104 str = fold_convert (pchar_type_node, str);
1105 return build_fold_indirect_ref (str);
1111 /* Compare two strings. If they are all single characters, the result is the
1112 subtraction of them. Otherwise, we build a library call. */
1115 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1122 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1123 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1125 type = gfc_get_int_type (gfc_default_integer_kind);
1127 sc1 = gfc_to_single_character (len1, str1);
1128 sc2 = gfc_to_single_character (len2, str2);
1130 /* Deal with single character specially. */
1131 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1133 sc1 = fold_convert (type, sc1);
1134 sc2 = fold_convert (type, sc2);
1135 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1140 tmp = gfc_chainon_list (tmp, len1);
1141 tmp = gfc_chainon_list (tmp, str1);
1142 tmp = gfc_chainon_list (tmp, len2);
1143 tmp = gfc_chainon_list (tmp, str2);
1145 /* Build a call for the comparison. */
1146 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1153 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1157 if (sym->attr.dummy)
1159 tmp = gfc_get_symbol_decl (sym);
1160 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1161 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1165 if (!sym->backend_decl)
1166 sym->backend_decl = gfc_get_extern_function_decl (sym);
1168 tmp = sym->backend_decl;
1169 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1171 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1172 tmp = build_fold_addr_expr (tmp);
1179 /* Initialize MAPPING. */
1182 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1184 mapping->syms = NULL;
1185 mapping->charlens = NULL;
1189 /* Free all memory held by MAPPING (but not MAPPING itself). */
1192 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1194 gfc_interface_sym_mapping *sym;
1195 gfc_interface_sym_mapping *nextsym;
1197 gfc_charlen *nextcl;
1199 for (sym = mapping->syms; sym; sym = nextsym)
1201 nextsym = sym->next;
1202 gfc_free_symbol (sym->new->n.sym);
1203 gfc_free (sym->new);
1206 for (cl = mapping->charlens; cl; cl = nextcl)
1209 gfc_free_expr (cl->length);
1215 /* Return a copy of gfc_charlen CL. Add the returned structure to
1216 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1218 static gfc_charlen *
1219 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1224 new = gfc_get_charlen ();
1225 new->next = mapping->charlens;
1226 new->length = gfc_copy_expr (cl->length);
1228 mapping->charlens = new;
1233 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1234 array variable that can be used as the actual argument for dummy
1235 argument SYM. Add any initialization code to BLOCK. PACKED is as
1236 for gfc_get_nodesc_array_type and DATA points to the first element
1237 in the passed array. */
1240 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1241 int packed, tree data)
1246 type = gfc_typenode_for_spec (&sym->ts);
1247 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1249 var = gfc_create_var (type, "ifm");
1250 gfc_add_modify_expr (block, var, fold_convert (type, data));
1256 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1257 and offset of descriptorless array type TYPE given that it has the same
1258 size as DESC. Add any set-up code to BLOCK. */
1261 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1268 offset = gfc_index_zero_node;
1269 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1271 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1272 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1274 dim = gfc_rank_cst[n];
1275 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1276 gfc_conv_descriptor_ubound (desc, dim),
1277 gfc_conv_descriptor_lbound (desc, dim));
1278 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1279 GFC_TYPE_ARRAY_LBOUND (type, n),
1281 tmp = gfc_evaluate_now (tmp, block);
1282 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1284 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1285 GFC_TYPE_ARRAY_LBOUND (type, n),
1286 GFC_TYPE_ARRAY_STRIDE (type, n));
1287 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1289 offset = gfc_evaluate_now (offset, block);
1290 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1294 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1295 in SE. The caller may still use se->expr and se->string_length after
1296 calling this function. */
1299 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1300 gfc_symbol * sym, gfc_se * se)
1302 gfc_interface_sym_mapping *sm;
1306 gfc_symbol *new_sym;
1308 gfc_symtree *new_symtree;
1310 /* Create a new symbol to represent the actual argument. */
1311 new_sym = gfc_new_symbol (sym->name, NULL);
1312 new_sym->ts = sym->ts;
1313 new_sym->attr.referenced = 1;
1314 new_sym->attr.dimension = sym->attr.dimension;
1315 new_sym->attr.pointer = sym->attr.pointer;
1316 new_sym->attr.allocatable = sym->attr.allocatable;
1317 new_sym->attr.flavor = sym->attr.flavor;
1319 /* Create a fake symtree for it. */
1321 new_symtree = gfc_new_symtree (&root, sym->name);
1322 new_symtree->n.sym = new_sym;
1323 gcc_assert (new_symtree == root);
1325 /* Create a dummy->actual mapping. */
1326 sm = gfc_getmem (sizeof (*sm));
1327 sm->next = mapping->syms;
1329 sm->new = new_symtree;
1332 /* Stabilize the argument's value. */
1333 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1335 if (sym->ts.type == BT_CHARACTER)
1337 /* Create a copy of the dummy argument's length. */
1338 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1340 /* If the length is specified as "*", record the length that
1341 the caller is passing. We should use the callee's length
1342 in all other cases. */
1343 if (!new_sym->ts.cl->length)
1345 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1346 new_sym->ts.cl->backend_decl = se->string_length;
1350 /* Use the passed value as-is if the argument is a function. */
1351 if (sym->attr.flavor == FL_PROCEDURE)
1354 /* If the argument is either a string or a pointer to a string,
1355 convert it to a boundless character type. */
1356 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1358 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1359 tmp = build_pointer_type (tmp);
1360 if (sym->attr.pointer)
1361 tmp = build_pointer_type (tmp);
1363 value = fold_convert (tmp, se->expr);
1364 if (sym->attr.pointer)
1365 value = build_fold_indirect_ref (value);
1368 /* If the argument is a scalar, a pointer to an array or an allocatable,
1370 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1371 value = build_fold_indirect_ref (se->expr);
1373 /* For character(*), use the actual argument's descriptor. */
1374 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1375 value = build_fold_indirect_ref (se->expr);
1377 /* If the argument is an array descriptor, use it to determine
1378 information about the actual argument's shape. */
1379 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1380 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1382 /* Get the actual argument's descriptor. */
1383 desc = build_fold_indirect_ref (se->expr);
1385 /* Create the replacement variable. */
1386 tmp = gfc_conv_descriptor_data_get (desc);
1387 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1389 /* Use DESC to work out the upper bounds, strides and offset. */
1390 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1393 /* Otherwise we have a packed array. */
1394 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1396 new_sym->backend_decl = value;
1400 /* Called once all dummy argument mappings have been added to MAPPING,
1401 but before the mapping is used to evaluate expressions. Pre-evaluate
1402 the length of each argument, adding any initialization code to PRE and
1403 any finalization code to POST. */
1406 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1407 stmtblock_t * pre, stmtblock_t * post)
1409 gfc_interface_sym_mapping *sym;
1413 for (sym = mapping->syms; sym; sym = sym->next)
1414 if (sym->new->n.sym->ts.type == BT_CHARACTER
1415 && !sym->new->n.sym->ts.cl->backend_decl)
1417 expr = sym->new->n.sym->ts.cl->length;
1418 gfc_apply_interface_mapping_to_expr (mapping, expr);
1419 gfc_init_se (&se, NULL);
1420 gfc_conv_expr (&se, expr);
1422 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1423 gfc_add_block_to_block (pre, &se.pre);
1424 gfc_add_block_to_block (post, &se.post);
1426 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1431 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1435 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1436 gfc_constructor * c)
1438 for (; c; c = c->next)
1440 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1443 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1444 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1445 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1451 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1455 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1460 for (; ref; ref = ref->next)
1464 for (n = 0; n < ref->u.ar.dimen; n++)
1466 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1467 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1468 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1470 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1477 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1478 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1484 /* EXPR is a copy of an expression that appeared in the interface
1485 associated with MAPPING. Walk it recursively looking for references to
1486 dummy arguments that MAPPING maps to actual arguments. Replace each such
1487 reference with a reference to the associated actual argument. */
1490 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1493 gfc_interface_sym_mapping *sym;
1494 gfc_actual_arglist *actual;
1499 /* Copying an expression does not copy its length, so do that here. */
1500 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1502 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1503 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1506 /* Apply the mapping to any references. */
1507 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1509 /* ...and to the expression's symbol, if it has one. */
1511 for (sym = mapping->syms; sym; sym = sym->next)
1512 if (sym->old == expr->symtree->n.sym)
1513 expr->symtree = sym->new;
1515 /* ...and to subexpressions in expr->value. */
1516 switch (expr->expr_type)
1521 case EXPR_SUBSTRING:
1525 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1526 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1530 for (sym = mapping->syms; sym; sym = sym->next)
1531 if (sym->old == expr->value.function.esym)
1532 expr->value.function.esym = sym->new->n.sym;
1534 for (actual = expr->value.function.actual; actual; actual = actual->next)
1535 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1539 case EXPR_STRUCTURE:
1540 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1546 /* Evaluate interface expression EXPR using MAPPING. Store the result
1550 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1551 gfc_se * se, gfc_expr * expr)
1553 expr = gfc_copy_expr (expr);
1554 gfc_apply_interface_mapping_to_expr (mapping, expr);
1555 gfc_conv_expr (se, expr);
1556 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1557 gfc_free_expr (expr);
1560 /* Returns a reference to a temporary array into which a component of
1561 an actual argument derived type array is copied and then returned
1562 after the function call.
1563 TODO Get rid of this kludge, when array descriptors are capable of
1564 handling aliased arrays. */
1567 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
1583 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1585 gfc_init_se (&lse, NULL);
1586 gfc_init_se (&rse, NULL);
1588 /* Walk the argument expression. */
1589 rss = gfc_walk_expr (expr);
1591 gcc_assert (rss != gfc_ss_terminator);
1593 /* Initialize the scalarizer. */
1594 gfc_init_loopinfo (&loop);
1595 gfc_add_ss_to_loop (&loop, rss);
1597 /* Calculate the bounds of the scalarization. */
1598 gfc_conv_ss_startstride (&loop);
1600 /* Build an ss for the temporary. */
1601 base_type = gfc_typenode_for_spec (&expr->ts);
1602 if (GFC_ARRAY_TYPE_P (base_type)
1603 || GFC_DESCRIPTOR_TYPE_P (base_type))
1604 base_type = gfc_get_element_type (base_type);
1606 loop.temp_ss = gfc_get_ss ();;
1607 loop.temp_ss->type = GFC_SS_TEMP;
1608 loop.temp_ss->data.temp.type = base_type;
1610 if (expr->ts.type == BT_CHARACTER)
1611 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1613 loop.temp_ss->data.temp.dimen = loop.dimen;
1614 loop.temp_ss->next = gfc_ss_terminator;
1616 /* Associate the SS with the loop. */
1617 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1619 /* Setup the scalarizing loops. */
1620 gfc_conv_loop_setup (&loop);
1622 /* Pass the temporary descriptor back to the caller. */
1623 info = &loop.temp_ss->data.info;
1624 parmse->expr = info->descriptor;
1626 /* Setup the gfc_se structures. */
1627 gfc_copy_loopinfo_to_se (&lse, &loop);
1628 gfc_copy_loopinfo_to_se (&rse, &loop);
1631 lse.ss = loop.temp_ss;
1632 gfc_mark_ss_chain_used (rss, 1);
1633 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1635 /* Start the scalarized loop body. */
1636 gfc_start_scalarized_body (&loop, &body);
1638 /* Translate the expression. */
1639 gfc_conv_expr (&rse, expr);
1641 gfc_conv_tmp_array_ref (&lse);
1642 gfc_advance_se_ss_chain (&lse);
1644 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1645 gfc_add_expr_to_block (&body, tmp);
1647 gcc_assert (rse.ss == gfc_ss_terminator);
1649 gfc_trans_scalarizing_loops (&loop, &body);
1651 /* Add the post block after the second loop, so that any
1652 freeing of allocated memory is done at the right time. */
1653 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1655 /**********Copy the temporary back again.*********/
1657 gfc_init_se (&lse, NULL);
1658 gfc_init_se (&rse, NULL);
1660 /* Walk the argument expression. */
1661 lss = gfc_walk_expr (expr);
1662 rse.ss = loop.temp_ss;
1665 /* Initialize the scalarizer. */
1666 gfc_init_loopinfo (&loop2);
1667 gfc_add_ss_to_loop (&loop2, lss);
1669 /* Calculate the bounds of the scalarization. */
1670 gfc_conv_ss_startstride (&loop2);
1672 /* Setup the scalarizing loops. */
1673 gfc_conv_loop_setup (&loop2);
1675 gfc_copy_loopinfo_to_se (&lse, &loop2);
1676 gfc_copy_loopinfo_to_se (&rse, &loop2);
1678 gfc_mark_ss_chain_used (lss, 1);
1679 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1681 /* Declare the variable to hold the temporary offset and start the
1682 scalarized loop body. */
1683 offset = gfc_create_var (gfc_array_index_type, NULL);
1684 gfc_start_scalarized_body (&loop2, &body);
1686 /* Build the offsets for the temporary from the loop variables. The
1687 temporary array has lbounds of zero and strides of one in all
1688 dimensions, so this is very simple. The offset is only computed
1689 outside the innermost loop, so the overall transfer could be
1690 optimised further. */
1691 info = &rse.ss->data.info;
1693 tmp_index = gfc_index_zero_node;
1694 for (n = info->dimen - 1; n > 0; n--)
1697 tmp = rse.loop->loopvar[n];
1698 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1699 tmp, rse.loop->from[n]);
1700 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1703 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1704 rse.loop->to[n-1], rse.loop->from[n-1]);
1705 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1706 tmp_str, gfc_index_one_node);
1708 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1712 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1713 tmp_index, rse.loop->from[0]);
1714 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1716 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1717 rse.loop->loopvar[0], offset);
1719 /* Now use the offset for the reference. */
1720 tmp = build_fold_indirect_ref (info->data);
1721 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1723 if (expr->ts.type == BT_CHARACTER)
1724 rse.string_length = expr->ts.cl->backend_decl;
1726 gfc_conv_expr (&lse, expr);
1728 gcc_assert (lse.ss == gfc_ss_terminator);
1730 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1731 gfc_add_expr_to_block (&body, tmp);
1733 /* Generate the copying loops. */
1734 gfc_trans_scalarizing_loops (&loop2, &body);
1736 /* Wrap the whole thing up by adding the second loop to the post-block
1737 and following it by the post-block of the fist loop. In this way,
1738 if the temporary needs freeing, it is done after use! */
1739 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1740 gfc_add_block_to_block (&parmse->post, &loop2.post);
1742 gfc_add_block_to_block (&parmse->post, &loop.post);
1744 gfc_cleanup_loop (&loop);
1745 gfc_cleanup_loop (&loop2);
1747 /* Pass the string length to the argument expression. */
1748 if (expr->ts.type == BT_CHARACTER)
1749 parmse->string_length = expr->ts.cl->backend_decl;
1751 /* We want either the address for the data or the address of the descriptor,
1752 depending on the mode of passing array arguments. */
1754 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1756 parmse->expr = build_fold_addr_expr (parmse->expr);
1761 /* Is true if the last array reference is followed by a component reference. */
1764 is_aliased_array (gfc_expr * e)
1770 for (ref = e->ref; ref; ref = ref->next)
1772 if (ref->type == REF_ARRAY)
1775 if (ref->next == NULL && ref->type == REF_COMPONENT)
1781 /* Generate code for a procedure call. Note can return se->post != NULL.
1782 If se->direct_byref is set then se->expr contains the return parameter.
1783 Return nonzero, if the call has alternate specifiers. */
1786 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1787 gfc_actual_arglist * arg)
1789 gfc_interface_mapping mapping;
1802 gfc_formal_arglist *formal;
1803 int has_alternate_specifier = 0;
1804 bool need_interface_mapping;
1809 arglist = NULL_TREE;
1810 retargs = NULL_TREE;
1811 stringargs = NULL_TREE;
1817 if (!sym->attr.elemental)
1819 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1820 if (se->ss->useflags)
1822 gcc_assert (gfc_return_by_reference (sym)
1823 && sym->result->attr.dimension);
1824 gcc_assert (se->loop != NULL);
1826 /* Access the previously obtained result. */
1827 gfc_conv_tmp_array_ref (se);
1828 gfc_advance_se_ss_chain (se);
1832 info = &se->ss->data.info;
1837 gfc_init_interface_mapping (&mapping);
1838 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1839 && sym->ts.cl->length
1840 && sym->ts.cl->length->expr_type
1842 || sym->attr.dimension);
1843 formal = sym->formal;
1844 /* Evaluate the arguments. */
1845 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1847 if (arg->expr == NULL)
1850 if (se->ignore_optional)
1852 /* Some intrinsics have already been resolved to the correct
1856 else if (arg->label)
1858 has_alternate_specifier = 1;
1863 /* Pass a NULL pointer for an absent arg. */
1864 gfc_init_se (&parmse, NULL);
1865 parmse.expr = null_pointer_node;
1866 if (arg->missing_arg_type == BT_CHARACTER)
1867 parmse.string_length = convert (gfc_charlen_type_node,
1871 else if (se->ss && se->ss->useflags)
1873 /* An elemental function inside a scalarized loop. */
1874 gfc_init_se (&parmse, se);
1875 gfc_conv_expr_reference (&parmse, arg->expr);
1879 /* A scalar or transformational function. */
1880 gfc_init_se (&parmse, NULL);
1881 argss = gfc_walk_expr (arg->expr);
1883 if (argss == gfc_ss_terminator)
1885 gfc_conv_expr_reference (&parmse, arg->expr);
1886 if (formal && formal->sym->attr.pointer
1887 && arg->expr->expr_type != EXPR_NULL)
1889 /* Scalar pointer dummy args require an extra level of
1890 indirection. The null pointer already contains
1891 this level of indirection. */
1892 parmse.expr = build_fold_addr_expr (parmse.expr);
1897 /* If the procedure requires an explicit interface, the actual
1898 argument is passed according to the corresponding formal
1899 argument. If the corresponding formal argument is a POINTER,
1900 ALLOCATABLE or assumed shape, we do not use g77's calling
1901 convention, and pass the address of the array descriptor
1902 instead. Otherwise we use g77's calling convention. */
1904 f = (formal != NULL)
1905 && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
1906 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1907 f = f || !sym->attr.always_explicit;
1908 if (arg->expr->expr_type == EXPR_VARIABLE
1909 && is_aliased_array (arg->expr))
1910 /* The actual argument is a component reference to an
1911 array of derived types. In this case, the argument
1912 is converted to a temporary, which is passed and then
1913 written back after the procedure call. */
1914 gfc_conv_aliased_arg (&parmse, arg->expr, f);
1916 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1918 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
1919 allocated on entry, it must be deallocated. */
1920 if (formal && formal->sym->attr.allocatable
1921 && formal->sym->attr.intent == INTENT_OUT)
1923 tmp = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
1924 gfc_add_expr_to_block (&se->pre, tmp);
1930 if (formal && need_interface_mapping)
1931 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1933 gfc_add_block_to_block (&se->pre, &parmse.pre);
1934 gfc_add_block_to_block (&se->post, &parmse.post);
1936 /* Character strings are passed as two parameters, a length and a
1938 if (parmse.string_length != NULL_TREE)
1939 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1941 arglist = gfc_chainon_list (arglist, parmse.expr);
1943 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1946 if (ts.type == BT_CHARACTER)
1948 if (sym->ts.cl->length == NULL)
1950 /* Assumed character length results are not allowed by 5.1.1.5 of the
1951 standard and are trapped in resolve.c; except in the case of SPREAD
1952 (and other intrinsics?). In this case, we take the character length
1953 of the first argument for the result. */
1954 cl.backend_decl = TREE_VALUE (stringargs);
1958 /* Calculate the length of the returned string. */
1959 gfc_init_se (&parmse, NULL);
1960 if (need_interface_mapping)
1961 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1963 gfc_conv_expr (&parmse, sym->ts.cl->length);
1964 gfc_add_block_to_block (&se->pre, &parmse.pre);
1965 gfc_add_block_to_block (&se->post, &parmse.post);
1966 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1969 /* Set up a charlen structure for it. */
1974 len = cl.backend_decl;
1977 byref = gfc_return_by_reference (sym);
1980 if (se->direct_byref)
1981 retargs = gfc_chainon_list (retargs, se->expr);
1982 else if (sym->result->attr.dimension)
1984 gcc_assert (se->loop && info);
1986 /* Set the type of the array. */
1987 tmp = gfc_typenode_for_spec (&ts);
1988 info->dimen = se->loop->dimen;
1990 /* Evaluate the bounds of the result, if known. */
1991 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1993 /* Create a temporary to store the result. In case the function
1994 returns a pointer, the temporary will be a shallow copy and
1995 mustn't be deallocated. */
1996 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
1997 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
1998 false, !sym->attr.pointer, callee_alloc);
2000 /* Zero the first stride to indicate a temporary. */
2001 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
2002 gfc_add_modify_expr (&se->pre, tmp,
2003 convert (TREE_TYPE (tmp), integer_zero_node));
2005 /* Pass the temporary as the first argument. */
2006 tmp = info->descriptor;
2007 tmp = build_fold_addr_expr (tmp);
2008 retargs = gfc_chainon_list (retargs, tmp);
2010 else if (ts.type == BT_CHARACTER)
2012 /* Pass the string length. */
2013 type = gfc_get_character_type (ts.kind, ts.cl);
2014 type = build_pointer_type (type);
2016 /* Return an address to a char[0:len-1]* temporary for
2017 character pointers. */
2018 if (sym->attr.pointer || sym->attr.allocatable)
2020 /* Build char[0:len-1] * pstr. */
2021 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2022 build_int_cst (gfc_charlen_type_node, 1));
2023 tmp = build_range_type (gfc_array_index_type,
2024 gfc_index_zero_node, tmp);
2025 tmp = build_array_type (gfc_character1_type_node, tmp);
2026 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2028 /* Provide an address expression for the function arguments. */
2029 var = build_fold_addr_expr (var);
2032 var = gfc_conv_string_tmp (se, type, len);
2034 retargs = gfc_chainon_list (retargs, var);
2038 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2040 type = gfc_get_complex_type (ts.kind);
2041 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2042 retargs = gfc_chainon_list (retargs, var);
2045 /* Add the string length to the argument list. */
2046 if (ts.type == BT_CHARACTER)
2047 retargs = gfc_chainon_list (retargs, len);
2049 gfc_free_interface_mapping (&mapping);
2051 /* Add the return arguments. */
2052 arglist = chainon (retargs, arglist);
2054 /* Add the hidden string length parameters to the arguments. */
2055 arglist = chainon (arglist, stringargs);
2057 /* Generate the actual call. */
2058 gfc_conv_function_val (se, sym);
2059 /* If there are alternate return labels, function type should be
2060 integer. Can't modify the type in place though, since it can be shared
2061 with other functions. */
2062 if (has_alternate_specifier
2063 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2065 gcc_assert (! sym->attr.dummy);
2066 TREE_TYPE (sym->backend_decl)
2067 = build_function_type (integer_type_node,
2068 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2069 se->expr = build_fold_addr_expr (sym->backend_decl);
2072 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2073 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2074 arglist, NULL_TREE);
2076 /* If we have a pointer function, but we don't want a pointer, e.g.
2079 where f is pointer valued, we have to dereference the result. */
2080 if (!se->want_pointer && !byref && sym->attr.pointer)
2081 se->expr = build_fold_indirect_ref (se->expr);
2083 /* f2c calling conventions require a scalar default real function to
2084 return a double precision result. Convert this back to default
2085 real. We only care about the cases that can happen in Fortran 77.
2087 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2088 && sym->ts.kind == gfc_default_real_kind
2089 && !sym->attr.always_explicit)
2090 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2092 /* A pure function may still have side-effects - it may modify its
2094 TREE_SIDE_EFFECTS (se->expr) = 1;
2096 if (!sym->attr.pure)
2097 TREE_SIDE_EFFECTS (se->expr) = 1;
2102 /* Add the function call to the pre chain. There is no expression. */
2103 gfc_add_expr_to_block (&se->pre, se->expr);
2104 se->expr = NULL_TREE;
2106 if (!se->direct_byref)
2108 if (sym->attr.dimension)
2110 if (flag_bounds_check)
2112 /* Check the data pointer hasn't been modified. This would
2113 happen in a function returning a pointer. */
2114 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2115 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2117 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
2119 se->expr = info->descriptor;
2120 /* Bundle in the string length. */
2121 se->string_length = len;
2123 else if (sym->ts.type == BT_CHARACTER)
2125 /* Dereference for character pointer results. */
2126 if (sym->attr.pointer || sym->attr.allocatable)
2127 se->expr = build_fold_indirect_ref (var);
2131 se->string_length = len;
2135 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2136 se->expr = build_fold_indirect_ref (var);
2141 return has_alternate_specifier;
2145 /* Generate code to copy a string. */
2148 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
2149 tree slen, tree src)
2155 /* Deal with single character specially. */
2156 dsc = gfc_to_single_character (dlen, dest);
2157 ssc = gfc_to_single_character (slen, src);
2158 if (dsc != NULL_TREE && ssc != NULL_TREE)
2160 gfc_add_modify_expr (block, dsc, ssc);
2165 tmp = gfc_chainon_list (tmp, dlen);
2166 tmp = gfc_chainon_list (tmp, dest);
2167 tmp = gfc_chainon_list (tmp, slen);
2168 tmp = gfc_chainon_list (tmp, src);
2169 tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
2170 gfc_add_expr_to_block (block, tmp);
2174 /* Translate a statement function.
2175 The value of a statement function reference is obtained by evaluating the
2176 expression using the values of the actual arguments for the values of the
2177 corresponding dummy arguments. */
2180 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2184 gfc_formal_arglist *fargs;
2185 gfc_actual_arglist *args;
2188 gfc_saved_var *saved_vars;
2194 sym = expr->symtree->n.sym;
2195 args = expr->value.function.actual;
2196 gfc_init_se (&lse, NULL);
2197 gfc_init_se (&rse, NULL);
2200 for (fargs = sym->formal; fargs; fargs = fargs->next)
2202 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2203 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2205 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2207 /* Each dummy shall be specified, explicitly or implicitly, to be
2209 gcc_assert (fargs->sym->attr.dimension == 0);
2212 /* Create a temporary to hold the value. */
2213 type = gfc_typenode_for_spec (&fsym->ts);
2214 temp_vars[n] = gfc_create_var (type, fsym->name);
2216 if (fsym->ts.type == BT_CHARACTER)
2218 /* Copy string arguments. */
2221 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2222 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2224 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2225 tmp = gfc_build_addr_expr (build_pointer_type (type),
2228 gfc_conv_expr (&rse, args->expr);
2229 gfc_conv_string_parameter (&rse);
2230 gfc_add_block_to_block (&se->pre, &lse.pre);
2231 gfc_add_block_to_block (&se->pre, &rse.pre);
2233 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2235 gfc_add_block_to_block (&se->pre, &lse.post);
2236 gfc_add_block_to_block (&se->pre, &rse.post);
2240 /* For everything else, just evaluate the expression. */
2241 gfc_conv_expr (&lse, args->expr);
2243 gfc_add_block_to_block (&se->pre, &lse.pre);
2244 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2245 gfc_add_block_to_block (&se->pre, &lse.post);
2251 /* Use the temporary variables in place of the real ones. */
2252 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2253 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2255 gfc_conv_expr (se, sym->value);
2257 if (sym->ts.type == BT_CHARACTER)
2259 gfc_conv_const_charlen (sym->ts.cl);
2261 /* Force the expression to the correct length. */
2262 if (!INTEGER_CST_P (se->string_length)
2263 || tree_int_cst_lt (se->string_length,
2264 sym->ts.cl->backend_decl))
2266 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2267 tmp = gfc_create_var (type, sym->name);
2268 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2269 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2270 se->string_length, se->expr);
2273 se->string_length = sym->ts.cl->backend_decl;
2276 /* Restore the original variables. */
2277 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2278 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2279 gfc_free (saved_vars);
2283 /* Translate a function expression. */
2286 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2290 if (expr->value.function.isym)
2292 gfc_conv_intrinsic_function (se, expr);
2296 /* We distinguish statement functions from general functions to improve
2297 runtime performance. */
2298 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2300 gfc_conv_statement_function (se, expr);
2304 /* expr.value.function.esym is the resolved (specific) function symbol for
2305 most functions. However this isn't set for dummy procedures. */
2306 sym = expr->value.function.esym;
2308 sym = expr->symtree->n.sym;
2309 gfc_conv_function_call (se, sym, expr->value.function.actual);
2314 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2316 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2317 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2319 gfc_conv_tmp_array_ref (se);
2320 gfc_advance_se_ss_chain (se);
2324 /* Build a static initializer. EXPR is the expression for the initial value.
2325 The other parameters describe the variable of the component being
2326 initialized. EXPR may be null. */
2329 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2330 bool array, bool pointer)
2334 if (!(expr || pointer))
2339 /* Arrays need special handling. */
2341 return gfc_build_null_descriptor (type);
2343 return gfc_conv_array_initializer (type, expr);
2346 return fold_convert (type, null_pointer_node);
2352 gfc_init_se (&se, NULL);
2353 gfc_conv_structure (&se, expr, 1);
2357 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2360 gfc_init_se (&se, NULL);
2361 gfc_conv_constant (&se, expr);
2368 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2380 gfc_start_block (&block);
2382 /* Initialize the scalarizer. */
2383 gfc_init_loopinfo (&loop);
2385 gfc_init_se (&lse, NULL);
2386 gfc_init_se (&rse, NULL);
2389 rss = gfc_walk_expr (expr);
2390 if (rss == gfc_ss_terminator)
2392 /* The rhs is scalar. Add a ss for the expression. */
2393 rss = gfc_get_ss ();
2394 rss->next = gfc_ss_terminator;
2395 rss->type = GFC_SS_SCALAR;
2399 /* Create a SS for the destination. */
2400 lss = gfc_get_ss ();
2401 lss->type = GFC_SS_COMPONENT;
2403 lss->shape = gfc_get_shape (cm->as->rank);
2404 lss->next = gfc_ss_terminator;
2405 lss->data.info.dimen = cm->as->rank;
2406 lss->data.info.descriptor = dest;
2407 lss->data.info.data = gfc_conv_array_data (dest);
2408 lss->data.info.offset = gfc_conv_array_offset (dest);
2409 for (n = 0; n < cm->as->rank; n++)
2411 lss->data.info.dim[n] = n;
2412 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2413 lss->data.info.stride[n] = gfc_index_one_node;
2415 mpz_init (lss->shape[n]);
2416 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2417 cm->as->lower[n]->value.integer);
2418 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2421 /* Associate the SS with the loop. */
2422 gfc_add_ss_to_loop (&loop, lss);
2423 gfc_add_ss_to_loop (&loop, rss);
2425 /* Calculate the bounds of the scalarization. */
2426 gfc_conv_ss_startstride (&loop);
2428 /* Setup the scalarizing loops. */
2429 gfc_conv_loop_setup (&loop);
2431 /* Setup the gfc_se structures. */
2432 gfc_copy_loopinfo_to_se (&lse, &loop);
2433 gfc_copy_loopinfo_to_se (&rse, &loop);
2436 gfc_mark_ss_chain_used (rss, 1);
2438 gfc_mark_ss_chain_used (lss, 1);
2440 /* Start the scalarized loop body. */
2441 gfc_start_scalarized_body (&loop, &body);
2443 gfc_conv_tmp_array_ref (&lse);
2444 if (cm->ts.type == BT_CHARACTER)
2445 lse.string_length = cm->ts.cl->backend_decl;
2447 gfc_conv_expr (&rse, expr);
2449 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2450 gfc_add_expr_to_block (&body, tmp);
2452 gcc_assert (rse.ss == gfc_ss_terminator);
2454 /* Generate the copying loops. */
2455 gfc_trans_scalarizing_loops (&loop, &body);
2457 /* Wrap the whole thing up. */
2458 gfc_add_block_to_block (&block, &loop.pre);
2459 gfc_add_block_to_block (&block, &loop.post);
2461 for (n = 0; n < cm->as->rank; n++)
2462 mpz_clear (lss->shape[n]);
2463 gfc_free (lss->shape);
2465 gfc_cleanup_loop (&loop);
2467 return gfc_finish_block (&block);
2470 /* Assign a single component of a derived type constructor. */
2473 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2480 gfc_start_block (&block);
2483 gfc_init_se (&se, NULL);
2484 /* Pointer component. */
2487 /* Array pointer. */
2488 if (expr->expr_type == EXPR_NULL)
2489 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2492 rss = gfc_walk_expr (expr);
2493 se.direct_byref = 1;
2495 gfc_conv_expr_descriptor (&se, expr, rss);
2496 gfc_add_block_to_block (&block, &se.pre);
2497 gfc_add_block_to_block (&block, &se.post);
2502 /* Scalar pointers. */
2503 se.want_pointer = 1;
2504 gfc_conv_expr (&se, expr);
2505 gfc_add_block_to_block (&block, &se.pre);
2506 gfc_add_modify_expr (&block, dest,
2507 fold_convert (TREE_TYPE (dest), se.expr));
2508 gfc_add_block_to_block (&block, &se.post);
2511 else if (cm->dimension)
2513 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2514 gfc_add_expr_to_block (&block, tmp);
2516 else if (expr->ts.type == BT_DERIVED)
2518 /* Nested derived type. */
2519 tmp = gfc_trans_structure_assign (dest, expr);
2520 gfc_add_expr_to_block (&block, tmp);
2524 /* Scalar component. */
2527 gfc_init_se (&se, NULL);
2528 gfc_init_se (&lse, NULL);
2530 gfc_conv_expr (&se, expr);
2531 if (cm->ts.type == BT_CHARACTER)
2532 lse.string_length = cm->ts.cl->backend_decl;
2534 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2535 gfc_add_expr_to_block (&block, tmp);
2537 return gfc_finish_block (&block);
2540 /* Assign a derived type constructor to a variable. */
2543 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2551 gfc_start_block (&block);
2552 cm = expr->ts.derived->components;
2553 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2555 /* Skip absent members in default initializers. */
2559 field = cm->backend_decl;
2560 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2561 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2562 gfc_add_expr_to_block (&block, tmp);
2564 return gfc_finish_block (&block);
2567 /* Build an expression for a constructor. If init is nonzero then
2568 this is part of a static variable initializer. */
2571 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2578 VEC(constructor_elt,gc) *v = NULL;
2580 gcc_assert (se->ss == NULL);
2581 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2582 type = gfc_typenode_for_spec (&expr->ts);
2586 /* Create a temporary variable and fill it in. */
2587 se->expr = gfc_create_var (type, expr->ts.derived->name);
2588 tmp = gfc_trans_structure_assign (se->expr, expr);
2589 gfc_add_expr_to_block (&se->pre, tmp);
2593 cm = expr->ts.derived->components;
2594 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2596 /* Skip absent members in default initializers. */
2600 val = gfc_conv_initializer (c->expr, &cm->ts,
2601 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2603 /* Append it to the constructor list. */
2604 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2606 se->expr = build_constructor (type, v);
2610 /* Translate a substring expression. */
2613 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2619 gcc_assert (ref->type == REF_SUBSTRING);
2621 se->expr = gfc_build_string_const(expr->value.character.length,
2622 expr->value.character.string);
2623 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2624 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2626 gfc_conv_substring(se,ref,expr->ts.kind);
2630 /* Entry point for expression translation. Evaluates a scalar quantity.
2631 EXPR is the expression to be translated, and SE is the state structure if
2632 called from within the scalarized. */
2635 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2637 if (se->ss && se->ss->expr == expr
2638 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2640 /* Substitute a scalar expression evaluated outside the scalarization
2642 se->expr = se->ss->data.scalar.expr;
2643 se->string_length = se->ss->string_length;
2644 gfc_advance_se_ss_chain (se);
2648 switch (expr->expr_type)
2651 gfc_conv_expr_op (se, expr);
2655 gfc_conv_function_expr (se, expr);
2659 gfc_conv_constant (se, expr);
2663 gfc_conv_variable (se, expr);
2667 se->expr = null_pointer_node;
2670 case EXPR_SUBSTRING:
2671 gfc_conv_substring_expr (se, expr);
2674 case EXPR_STRUCTURE:
2675 gfc_conv_structure (se, expr, 0);
2679 gfc_conv_array_constructor_expr (se, expr);
2688 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2689 of an assignment. */
2691 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2693 gfc_conv_expr (se, expr);
2694 /* All numeric lvalues should have empty post chains. If not we need to
2695 figure out a way of rewriting an lvalue so that it has no post chain. */
2696 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2699 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2700 numeric expressions. Used for scalar values where inserting cleanup code
2703 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2707 gcc_assert (expr->ts.type != BT_CHARACTER);
2708 gfc_conv_expr (se, expr);
2711 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2712 gfc_add_modify_expr (&se->pre, val, se->expr);
2714 gfc_add_block_to_block (&se->pre, &se->post);
2718 /* Helper to translate and expression and convert it to a particular type. */
2720 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2722 gfc_conv_expr_val (se, expr);
2723 se->expr = convert (type, se->expr);
2727 /* Converts an expression so that it can be passed by reference. Scalar
2731 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2735 if (se->ss && se->ss->expr == expr
2736 && se->ss->type == GFC_SS_REFERENCE)
2738 se->expr = se->ss->data.scalar.expr;
2739 se->string_length = se->ss->string_length;
2740 gfc_advance_se_ss_chain (se);
2744 if (expr->ts.type == BT_CHARACTER)
2746 gfc_conv_expr (se, expr);
2747 gfc_conv_string_parameter (se);
2751 if (expr->expr_type == EXPR_VARIABLE)
2753 se->want_pointer = 1;
2754 gfc_conv_expr (se, expr);
2757 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2758 gfc_add_modify_expr (&se->pre, var, se->expr);
2759 gfc_add_block_to_block (&se->pre, &se->post);
2765 gfc_conv_expr (se, expr);
2767 /* Create a temporary var to hold the value. */
2768 if (TREE_CONSTANT (se->expr))
2770 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2771 DECL_INITIAL (var) = se->expr;
2776 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2777 gfc_add_modify_expr (&se->pre, var, se->expr);
2779 gfc_add_block_to_block (&se->pre, &se->post);
2781 /* Take the address of that value. */
2782 se->expr = build_fold_addr_expr (var);
2787 gfc_trans_pointer_assign (gfc_code * code)
2789 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2793 /* Generate code for a pointer assignment. */
2796 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2806 gfc_start_block (&block);
2808 gfc_init_se (&lse, NULL);
2810 lss = gfc_walk_expr (expr1);
2811 rss = gfc_walk_expr (expr2);
2812 if (lss == gfc_ss_terminator)
2814 /* Scalar pointers. */
2815 lse.want_pointer = 1;
2816 gfc_conv_expr (&lse, expr1);
2817 gcc_assert (rss == gfc_ss_terminator);
2818 gfc_init_se (&rse, NULL);
2819 rse.want_pointer = 1;
2820 gfc_conv_expr (&rse, expr2);
2821 gfc_add_block_to_block (&block, &lse.pre);
2822 gfc_add_block_to_block (&block, &rse.pre);
2823 gfc_add_modify_expr (&block, lse.expr,
2824 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2825 gfc_add_block_to_block (&block, &rse.post);
2826 gfc_add_block_to_block (&block, &lse.post);
2830 /* Array pointer. */
2831 gfc_conv_expr_descriptor (&lse, expr1, lss);
2832 switch (expr2->expr_type)
2835 /* Just set the data pointer to null. */
2836 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2840 /* Assign directly to the pointer's descriptor. */
2841 lse.direct_byref = 1;
2842 gfc_conv_expr_descriptor (&lse, expr2, rss);
2846 /* Assign to a temporary descriptor and then copy that
2847 temporary to the pointer. */
2849 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2852 lse.direct_byref = 1;
2853 gfc_conv_expr_descriptor (&lse, expr2, rss);
2854 gfc_add_modify_expr (&lse.pre, desc, tmp);
2857 gfc_add_block_to_block (&block, &lse.pre);
2858 gfc_add_block_to_block (&block, &lse.post);
2860 return gfc_finish_block (&block);
2864 /* Makes sure se is suitable for passing as a function string parameter. */
2865 /* TODO: Need to check all callers fo this function. It may be abused. */
2868 gfc_conv_string_parameter (gfc_se * se)
2872 if (TREE_CODE (se->expr) == STRING_CST)
2874 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2878 type = TREE_TYPE (se->expr);
2879 if (TYPE_STRING_FLAG (type))
2881 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2882 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2885 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2886 gcc_assert (se->string_length
2887 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2891 /* Generate code for assignment of scalar variables. Includes character
2895 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2899 gfc_init_block (&block);
2901 if (type == BT_CHARACTER)
2903 gcc_assert (lse->string_length != NULL_TREE
2904 && rse->string_length != NULL_TREE);
2906 gfc_conv_string_parameter (lse);
2907 gfc_conv_string_parameter (rse);
2909 gfc_add_block_to_block (&block, &lse->pre);
2910 gfc_add_block_to_block (&block, &rse->pre);
2912 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2913 rse->string_length, rse->expr);
2917 gfc_add_block_to_block (&block, &lse->pre);
2918 gfc_add_block_to_block (&block, &rse->pre);
2920 gfc_add_modify_expr (&block, lse->expr,
2921 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2924 gfc_add_block_to_block (&block, &lse->post);
2925 gfc_add_block_to_block (&block, &rse->post);
2927 return gfc_finish_block (&block);
2931 /* Try to translate array(:) = func (...), where func is a transformational
2932 array function, without using a temporary. Returns NULL is this isn't the
2936 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2941 bool seen_array_ref;
2943 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2944 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2947 /* Elemental functions don't need a temporary anyway. */
2948 if (expr2->value.function.esym != NULL
2949 && expr2->value.function.esym->attr.elemental)
2952 /* Fail if EXPR1 can't be expressed as a descriptor. */
2953 if (gfc_ref_needs_temporary_p (expr1->ref))
2956 /* Functions returning pointers need temporaries. */
2957 if (expr2->symtree->n.sym->attr.pointer
2958 || expr2->symtree->n.sym->attr.allocatable)
2961 /* Check that no LHS component references appear during an array
2962 reference. This is needed because we do not have the means to
2963 span any arbitrary stride with an array descriptor. This check
2964 is not needed for the rhs because the function result has to be
2966 seen_array_ref = false;
2967 for (ref = expr1->ref; ref; ref = ref->next)
2969 if (ref->type == REF_ARRAY)
2970 seen_array_ref= true;
2971 else if (ref->type == REF_COMPONENT && seen_array_ref)
2975 /* Check for a dependency. */
2976 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
2977 expr2->value.function.esym,
2978 expr2->value.function.actual))
2981 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2983 gcc_assert (expr2->value.function.isym
2984 || (gfc_return_by_reference (expr2->value.function.esym)
2985 && expr2->value.function.esym->result->attr.dimension));
2987 ss = gfc_walk_expr (expr1);
2988 gcc_assert (ss != gfc_ss_terminator);
2989 gfc_init_se (&se, NULL);
2990 gfc_start_block (&se.pre);
2991 se.want_pointer = 1;
2993 gfc_conv_array_parameter (&se, expr1, ss, 0);
2995 se.direct_byref = 1;
2996 se.ss = gfc_walk_expr (expr2);
2997 gcc_assert (se.ss != gfc_ss_terminator);
2998 gfc_conv_function_expr (&se, expr2);
2999 gfc_add_block_to_block (&se.pre, &se.post);
3001 return gfc_finish_block (&se.pre);
3005 /* Translate an assignment. Most of the code is concerned with
3006 setting up the scalarizer. */
3009 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
3014 gfc_ss *lss_section;
3021 /* Special case a single function returning an array. */
3022 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3024 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3029 /* Assignment of the form lhs = rhs. */
3030 gfc_start_block (&block);
3032 gfc_init_se (&lse, NULL);
3033 gfc_init_se (&rse, NULL);
3036 lss = gfc_walk_expr (expr1);
3038 if (lss != gfc_ss_terminator)
3040 /* The assignment needs scalarization. */
3043 /* Find a non-scalar SS from the lhs. */
3044 while (lss_section != gfc_ss_terminator
3045 && lss_section->type != GFC_SS_SECTION)
3046 lss_section = lss_section->next;
3048 gcc_assert (lss_section != gfc_ss_terminator);
3050 /* Initialize the scalarizer. */
3051 gfc_init_loopinfo (&loop);
3054 rss = gfc_walk_expr (expr2);
3055 if (rss == gfc_ss_terminator)
3057 /* The rhs is scalar. Add a ss for the expression. */
3058 rss = gfc_get_ss ();
3059 rss->next = gfc_ss_terminator;
3060 rss->type = GFC_SS_SCALAR;
3063 /* Associate the SS with the loop. */
3064 gfc_add_ss_to_loop (&loop, lss);
3065 gfc_add_ss_to_loop (&loop, rss);
3067 /* Calculate the bounds of the scalarization. */
3068 gfc_conv_ss_startstride (&loop);
3069 /* Resolve any data dependencies in the statement. */
3070 gfc_conv_resolve_dependencies (&loop, lss, rss);
3071 /* Setup the scalarizing loops. */
3072 gfc_conv_loop_setup (&loop);
3074 /* Setup the gfc_se structures. */
3075 gfc_copy_loopinfo_to_se (&lse, &loop);
3076 gfc_copy_loopinfo_to_se (&rse, &loop);
3079 gfc_mark_ss_chain_used (rss, 1);
3080 if (loop.temp_ss == NULL)
3083 gfc_mark_ss_chain_used (lss, 1);
3087 lse.ss = loop.temp_ss;
3088 gfc_mark_ss_chain_used (lss, 3);
3089 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3092 /* Start the scalarized loop body. */
3093 gfc_start_scalarized_body (&loop, &body);
3096 gfc_init_block (&body);
3098 /* Translate the expression. */
3099 gfc_conv_expr (&rse, expr2);
3101 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3103 gfc_conv_tmp_array_ref (&lse);
3104 gfc_advance_se_ss_chain (&lse);
3107 gfc_conv_expr (&lse, expr1);
3109 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3110 gfc_add_expr_to_block (&body, tmp);
3112 if (lss == gfc_ss_terminator)
3114 /* Use the scalar assignment as is. */
3115 gfc_add_block_to_block (&block, &body);
3119 gcc_assert (lse.ss == gfc_ss_terminator
3120 && rse.ss == gfc_ss_terminator);
3122 if (loop.temp_ss != NULL)
3124 gfc_trans_scalarized_loop_boundary (&loop, &body);
3126 /* We need to copy the temporary to the actual lhs. */
3127 gfc_init_se (&lse, NULL);
3128 gfc_init_se (&rse, NULL);
3129 gfc_copy_loopinfo_to_se (&lse, &loop);
3130 gfc_copy_loopinfo_to_se (&rse, &loop);
3132 rse.ss = loop.temp_ss;
3135 gfc_conv_tmp_array_ref (&rse);
3136 gfc_advance_se_ss_chain (&rse);
3137 gfc_conv_expr (&lse, expr1);
3139 gcc_assert (lse.ss == gfc_ss_terminator
3140 && rse.ss == gfc_ss_terminator);
3142 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3143 gfc_add_expr_to_block (&body, tmp);
3145 /* Generate the copying loops. */
3146 gfc_trans_scalarizing_loops (&loop, &body);
3148 /* Wrap the whole thing up. */
3149 gfc_add_block_to_block (&block, &loop.pre);
3150 gfc_add_block_to_block (&block, &loop.post);
3152 gfc_cleanup_loop (&loop);
3155 return gfc_finish_block (&block);
3159 gfc_trans_assign (gfc_code * code)
3161 return gfc_trans_assignment (code->expr, code->expr2);