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. */
329 return_value = sym->attr.function && sym->result == sym;
330 alternate_entry = sym->attr.function && sym->attr.entry
331 && sym->result == sym;
332 entry_master = sym->attr.result
333 && sym->ns->proc_name->attr.entry_master
334 && !gfc_return_by_reference (sym->ns->proc_name);
335 parent_decl = DECL_CONTEXT (current_function_decl);
337 if ((se->expr == parent_decl && return_value)
338 || (sym->ns && sym->ns->proc_name
339 && sym->ns->proc_name->backend_decl == parent_decl
340 && (alternate_entry || entry_master)))
345 /* Special case for assigning the return value of a function.
346 Self recursive functions must have an explicit return value. */
347 if (sym->attr.function && sym->result == sym
348 && (se->expr == current_function_decl || parent_flag))
349 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
351 /* Similarly for alternate entry points. */
352 else if (alternate_entry
353 && (sym->ns->proc_name->backend_decl == current_function_decl
356 gfc_entry_list *el = NULL;
358 for (el = sym->ns->entries; el; el = el->next)
361 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
366 else if (entry_master
367 && (sym->ns->proc_name->backend_decl == current_function_decl
369 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
374 /* Procedure actual arguments. */
375 else if (sym->attr.flavor == FL_PROCEDURE
376 && se->expr != current_function_decl)
378 gcc_assert (se->want_pointer);
379 if (!sym->attr.dummy)
381 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
382 se->expr = build_fold_addr_expr (se->expr);
388 /* Dereference the expression, where needed. Since characters
389 are entirely different from other types, they are treated
391 if (sym->ts.type == BT_CHARACTER)
393 /* Dereference character pointer dummy arguments
395 if ((sym->attr.pointer || sym->attr.allocatable)
397 || sym->attr.function
398 || sym->attr.result))
399 se->expr = build_fold_indirect_ref (se->expr);
403 /* Dereference non-character scalar dummy arguments. */
404 if (sym->attr.dummy && !sym->attr.dimension)
405 se->expr = build_fold_indirect_ref (se->expr);
407 /* Dereference scalar hidden result. */
408 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
409 && (sym->attr.function || sym->attr.result)
410 && !sym->attr.dimension && !sym->attr.pointer)
411 se->expr = build_fold_indirect_ref (se->expr);
413 /* Dereference non-character pointer variables.
414 These must be dummies, results, or scalars. */
415 if ((sym->attr.pointer || sym->attr.allocatable)
417 || sym->attr.function
419 || !sym->attr.dimension))
420 se->expr = build_fold_indirect_ref (se->expr);
426 /* For character variables, also get the length. */
427 if (sym->ts.type == BT_CHARACTER)
429 /* If the character length of an entry isn't set, get the length from
430 the master function instead. */
431 if (sym->attr.entry && !sym->ts.cl->backend_decl)
432 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
434 se->string_length = sym->ts.cl->backend_decl;
435 gcc_assert (se->string_length);
443 /* Return the descriptor if that's what we want and this is an array
444 section reference. */
445 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
447 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
448 /* Return the descriptor for array pointers and allocations. */
450 && ref->next == NULL && (se->descriptor_only))
453 gfc_conv_array_ref (se, &ref->u.ar);
454 /* Return a pointer to an element. */
458 gfc_conv_component_ref (se, ref);
462 gfc_conv_substring (se, ref, expr->ts.kind);
471 /* Pointer assignment, allocation or pass by reference. Arrays are handled
473 if (se->want_pointer)
475 if (expr->ts.type == BT_CHARACTER)
476 gfc_conv_string_parameter (se);
478 se->expr = build_fold_addr_expr (se->expr);
483 /* Unary ops are easy... Or they would be if ! was a valid op. */
486 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
491 gcc_assert (expr->ts.type != BT_CHARACTER);
492 /* Initialize the operand. */
493 gfc_init_se (&operand, se);
494 gfc_conv_expr_val (&operand, expr->value.op.op1);
495 gfc_add_block_to_block (&se->pre, &operand.pre);
497 type = gfc_typenode_for_spec (&expr->ts);
499 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
500 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
501 All other unary operators have an equivalent GIMPLE unary operator. */
502 if (code == TRUTH_NOT_EXPR)
503 se->expr = build2 (EQ_EXPR, type, operand.expr,
504 convert (type, integer_zero_node));
506 se->expr = build1 (code, type, operand.expr);
510 /* Expand power operator to optimal multiplications when a value is raised
511 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
512 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
513 Programming", 3rd Edition, 1998. */
515 /* This code is mostly duplicated from expand_powi in the backend.
516 We establish the "optimal power tree" lookup table with the defined size.
517 The items in the table are the exponents used to calculate the index
518 exponents. Any integer n less than the value can get an "addition chain",
519 with the first node being one. */
520 #define POWI_TABLE_SIZE 256
522 /* The table is from builtins.c. */
523 static const unsigned char powi_table[POWI_TABLE_SIZE] =
525 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
526 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
527 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
528 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
529 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
530 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
531 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
532 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
533 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
534 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
535 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
536 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
537 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
538 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
539 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
540 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
541 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
542 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
543 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
544 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
545 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
546 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
547 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
548 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
549 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
550 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
551 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
552 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
553 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
554 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
555 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
556 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
559 /* If n is larger than lookup table's max index, we use the "window
561 #define POWI_WINDOW_SIZE 3
563 /* Recursive function to expand the power operator. The temporary
564 values are put in tmpvar. The function returns tmpvar[1] ** n. */
566 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
573 if (n < POWI_TABLE_SIZE)
578 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
579 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
583 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
584 op0 = gfc_conv_powi (se, n - digit, tmpvar);
585 op1 = gfc_conv_powi (se, digit, tmpvar);
589 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
593 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
594 tmp = gfc_evaluate_now (tmp, &se->pre);
596 if (n < POWI_TABLE_SIZE)
603 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
604 return 1. Else return 0 and a call to runtime library functions
605 will have to be built. */
607 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
612 tree vartmp[POWI_TABLE_SIZE];
616 type = TREE_TYPE (lhs);
617 n = abs (TREE_INT_CST_LOW (rhs));
618 sgn = tree_int_cst_sgn (rhs);
620 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
621 && (n > 2 || n < -1))
627 se->expr = gfc_build_const (type, integer_one_node);
630 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
631 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
633 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
634 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
635 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
636 convert (TREE_TYPE (lhs), integer_one_node));
639 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
642 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
643 se->expr = build3 (COND_EXPR, type, tmp,
644 convert (type, integer_one_node),
645 convert (type, integer_zero_node));
649 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
650 tmp = build3 (COND_EXPR, type, tmp,
651 convert (type, integer_minus_one_node),
652 convert (type, integer_zero_node));
653 se->expr = build3 (COND_EXPR, type, cond,
654 convert (type, integer_one_node),
659 memset (vartmp, 0, sizeof (vartmp));
663 tmp = gfc_build_const (type, integer_one_node);
664 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
667 se->expr = gfc_conv_powi (se, n, vartmp);
673 /* Power op (**). Constant integer exponent has special handling. */
676 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
678 tree gfc_int4_type_node;
686 gfc_init_se (&lse, se);
687 gfc_conv_expr_val (&lse, expr->value.op.op1);
688 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
689 gfc_add_block_to_block (&se->pre, &lse.pre);
691 gfc_init_se (&rse, se);
692 gfc_conv_expr_val (&rse, expr->value.op.op2);
693 gfc_add_block_to_block (&se->pre, &rse.pre);
695 if (expr->value.op.op2->ts.type == BT_INTEGER
696 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
697 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
700 gfc_int4_type_node = gfc_get_int_type (4);
702 kind = expr->value.op.op1->ts.kind;
703 switch (expr->value.op.op2->ts.type)
706 ikind = expr->value.op.op2->ts.kind;
711 rse.expr = convert (gfc_int4_type_node, rse.expr);
733 if (expr->value.op.op1->ts.type == BT_INTEGER)
734 lse.expr = convert (gfc_int4_type_node, lse.expr);
759 switch (expr->value.op.op1->ts.type)
762 if (kind == 3) /* Case 16 was not handled properly above. */
764 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
768 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
772 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
784 fndecl = built_in_decls[BUILT_IN_POWF];
787 fndecl = built_in_decls[BUILT_IN_POW];
791 fndecl = built_in_decls[BUILT_IN_POWL];
802 fndecl = gfor_fndecl_math_cpowf;
805 fndecl = gfor_fndecl_math_cpow;
808 fndecl = gfor_fndecl_math_cpowl10;
811 fndecl = gfor_fndecl_math_cpowl16;
823 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
824 tmp = gfc_chainon_list (tmp, rse.expr);
825 se->expr = build_function_call_expr (fndecl, tmp);
829 /* Generate code to allocate a string temporary. */
832 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
838 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
840 if (gfc_can_put_var_on_stack (len))
842 /* Create a temporary variable to hold the result. */
843 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
844 convert (gfc_charlen_type_node, integer_one_node));
845 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
846 tmp = build_array_type (gfc_character1_type_node, tmp);
847 var = gfc_create_var (tmp, "str");
848 var = gfc_build_addr_expr (type, var);
852 /* Allocate a temporary to hold the result. */
853 var = gfc_create_var (type, "pstr");
854 args = gfc_chainon_list (NULL_TREE, len);
855 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
856 tmp = convert (type, tmp);
857 gfc_add_modify_expr (&se->pre, var, tmp);
859 /* Free the temporary afterwards. */
860 tmp = convert (pvoid_type_node, var);
861 args = gfc_chainon_list (NULL_TREE, tmp);
862 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
863 gfc_add_expr_to_block (&se->post, tmp);
870 /* Handle a string concatenation operation. A temporary will be allocated to
874 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
884 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
885 && expr->value.op.op2->ts.type == BT_CHARACTER);
887 gfc_init_se (&lse, se);
888 gfc_conv_expr (&lse, expr->value.op.op1);
889 gfc_conv_string_parameter (&lse);
890 gfc_init_se (&rse, se);
891 gfc_conv_expr (&rse, expr->value.op.op2);
892 gfc_conv_string_parameter (&rse);
894 gfc_add_block_to_block (&se->pre, &lse.pre);
895 gfc_add_block_to_block (&se->pre, &rse.pre);
897 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
898 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
899 if (len == NULL_TREE)
901 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
902 lse.string_length, rse.string_length);
905 type = build_pointer_type (type);
907 var = gfc_conv_string_tmp (se, type, len);
909 /* Do the actual concatenation. */
911 args = gfc_chainon_list (args, len);
912 args = gfc_chainon_list (args, var);
913 args = gfc_chainon_list (args, lse.string_length);
914 args = gfc_chainon_list (args, lse.expr);
915 args = gfc_chainon_list (args, rse.string_length);
916 args = gfc_chainon_list (args, rse.expr);
917 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
918 gfc_add_expr_to_block (&se->pre, tmp);
920 /* Add the cleanup for the operands. */
921 gfc_add_block_to_block (&se->pre, &rse.post);
922 gfc_add_block_to_block (&se->pre, &lse.post);
925 se->string_length = len;
928 /* Translates an op expression. Common (binary) cases are handled by this
929 function, others are passed on. Recursion is used in either case.
930 We use the fact that (op1.ts == op2.ts) (except for the power
932 Operators need no special handling for scalarized expressions as long as
933 they call gfc_conv_simple_val to get their operands.
934 Character strings get special handling. */
937 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
949 switch (expr->value.op.operator)
951 case INTRINSIC_UPLUS:
952 case INTRINSIC_PARENTHESES:
953 gfc_conv_expr (se, expr->value.op.op1);
956 case INTRINSIC_UMINUS:
957 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
961 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
968 case INTRINSIC_MINUS:
972 case INTRINSIC_TIMES:
976 case INTRINSIC_DIVIDE:
977 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
978 an integer, we must round towards zero, so we use a
980 if (expr->ts.type == BT_INTEGER)
981 code = TRUNC_DIV_EXPR;
986 case INTRINSIC_POWER:
987 gfc_conv_power_op (se, expr);
990 case INTRINSIC_CONCAT:
991 gfc_conv_concat_op (se, expr);
995 code = TRUTH_ANDIF_EXPR;
1000 code = TRUTH_ORIF_EXPR;
1004 /* EQV and NEQV only work on logicals, but since we represent them
1005 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1014 case INTRINSIC_NEQV:
1044 case INTRINSIC_USER:
1045 case INTRINSIC_ASSIGN:
1046 /* These should be converted into function calls by the frontend. */
1050 fatal_error ("Unknown intrinsic op");
1054 /* The only exception to this is **, which is handled separately anyway. */
1055 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1057 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1061 gfc_init_se (&lse, se);
1062 gfc_conv_expr (&lse, expr->value.op.op1);
1063 gfc_add_block_to_block (&se->pre, &lse.pre);
1066 gfc_init_se (&rse, se);
1067 gfc_conv_expr (&rse, expr->value.op.op2);
1068 gfc_add_block_to_block (&se->pre, &rse.pre);
1072 gfc_conv_string_parameter (&lse);
1073 gfc_conv_string_parameter (&rse);
1075 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1076 rse.string_length, rse.expr);
1077 rse.expr = integer_zero_node;
1078 gfc_add_block_to_block (&lse.post, &rse.post);
1081 type = gfc_typenode_for_spec (&expr->ts);
1085 /* The result of logical ops is always boolean_type_node. */
1086 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1087 se->expr = convert (type, tmp);
1090 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1092 /* Add the post blocks. */
1093 gfc_add_block_to_block (&se->post, &rse.post);
1094 gfc_add_block_to_block (&se->post, &lse.post);
1097 /* If a string's length is one, we convert it to a single character. */
1100 gfc_to_single_character (tree len, tree str)
1102 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1104 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1105 && TREE_INT_CST_HIGH (len) == 0)
1107 str = fold_convert (pchar_type_node, str);
1108 return build_fold_indirect_ref (str);
1114 /* Compare two strings. If they are all single characters, the result is the
1115 subtraction of them. Otherwise, we build a library call. */
1118 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1125 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1126 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1128 type = gfc_get_int_type (gfc_default_integer_kind);
1130 sc1 = gfc_to_single_character (len1, str1);
1131 sc2 = gfc_to_single_character (len2, str2);
1133 /* Deal with single character specially. */
1134 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1136 sc1 = fold_convert (type, sc1);
1137 sc2 = fold_convert (type, sc2);
1138 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1143 tmp = gfc_chainon_list (tmp, len1);
1144 tmp = gfc_chainon_list (tmp, str1);
1145 tmp = gfc_chainon_list (tmp, len2);
1146 tmp = gfc_chainon_list (tmp, str2);
1148 /* Build a call for the comparison. */
1149 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1156 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1160 if (sym->attr.dummy)
1162 tmp = gfc_get_symbol_decl (sym);
1163 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1164 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1168 if (!sym->backend_decl)
1169 sym->backend_decl = gfc_get_extern_function_decl (sym);
1171 tmp = sym->backend_decl;
1172 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1174 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1175 tmp = build_fold_addr_expr (tmp);
1182 /* Initialize MAPPING. */
1185 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1187 mapping->syms = NULL;
1188 mapping->charlens = NULL;
1192 /* Free all memory held by MAPPING (but not MAPPING itself). */
1195 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1197 gfc_interface_sym_mapping *sym;
1198 gfc_interface_sym_mapping *nextsym;
1200 gfc_charlen *nextcl;
1202 for (sym = mapping->syms; sym; sym = nextsym)
1204 nextsym = sym->next;
1205 gfc_free_symbol (sym->new->n.sym);
1206 gfc_free (sym->new);
1209 for (cl = mapping->charlens; cl; cl = nextcl)
1212 gfc_free_expr (cl->length);
1218 /* Return a copy of gfc_charlen CL. Add the returned structure to
1219 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1221 static gfc_charlen *
1222 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1227 new = gfc_get_charlen ();
1228 new->next = mapping->charlens;
1229 new->length = gfc_copy_expr (cl->length);
1231 mapping->charlens = new;
1236 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1237 array variable that can be used as the actual argument for dummy
1238 argument SYM. Add any initialization code to BLOCK. PACKED is as
1239 for gfc_get_nodesc_array_type and DATA points to the first element
1240 in the passed array. */
1243 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1244 int packed, tree data)
1249 type = gfc_typenode_for_spec (&sym->ts);
1250 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1252 var = gfc_create_var (type, "ifm");
1253 gfc_add_modify_expr (block, var, fold_convert (type, data));
1259 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1260 and offset of descriptorless array type TYPE given that it has the same
1261 size as DESC. Add any set-up code to BLOCK. */
1264 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1271 offset = gfc_index_zero_node;
1272 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1274 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1275 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1277 dim = gfc_rank_cst[n];
1278 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1279 gfc_conv_descriptor_ubound (desc, dim),
1280 gfc_conv_descriptor_lbound (desc, dim));
1281 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1282 GFC_TYPE_ARRAY_LBOUND (type, n),
1284 tmp = gfc_evaluate_now (tmp, block);
1285 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1287 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1288 GFC_TYPE_ARRAY_LBOUND (type, n),
1289 GFC_TYPE_ARRAY_STRIDE (type, n));
1290 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1292 offset = gfc_evaluate_now (offset, block);
1293 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1297 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1298 in SE. The caller may still use se->expr and se->string_length after
1299 calling this function. */
1302 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1303 gfc_symbol * sym, gfc_se * se)
1305 gfc_interface_sym_mapping *sm;
1309 gfc_symbol *new_sym;
1311 gfc_symtree *new_symtree;
1313 /* Create a new symbol to represent the actual argument. */
1314 new_sym = gfc_new_symbol (sym->name, NULL);
1315 new_sym->ts = sym->ts;
1316 new_sym->attr.referenced = 1;
1317 new_sym->attr.dimension = sym->attr.dimension;
1318 new_sym->attr.pointer = sym->attr.pointer;
1319 new_sym->attr.allocatable = sym->attr.allocatable;
1320 new_sym->attr.flavor = sym->attr.flavor;
1322 /* Create a fake symtree for it. */
1324 new_symtree = gfc_new_symtree (&root, sym->name);
1325 new_symtree->n.sym = new_sym;
1326 gcc_assert (new_symtree == root);
1328 /* Create a dummy->actual mapping. */
1329 sm = gfc_getmem (sizeof (*sm));
1330 sm->next = mapping->syms;
1332 sm->new = new_symtree;
1335 /* Stabilize the argument's value. */
1336 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1338 if (sym->ts.type == BT_CHARACTER)
1340 /* Create a copy of the dummy argument's length. */
1341 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1343 /* If the length is specified as "*", record the length that
1344 the caller is passing. We should use the callee's length
1345 in all other cases. */
1346 if (!new_sym->ts.cl->length)
1348 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1349 new_sym->ts.cl->backend_decl = se->string_length;
1353 /* Use the passed value as-is if the argument is a function. */
1354 if (sym->attr.flavor == FL_PROCEDURE)
1357 /* If the argument is either a string or a pointer to a string,
1358 convert it to a boundless character type. */
1359 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1361 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1362 tmp = build_pointer_type (tmp);
1363 if (sym->attr.pointer)
1364 tmp = build_pointer_type (tmp);
1366 value = fold_convert (tmp, se->expr);
1367 if (sym->attr.pointer)
1368 value = build_fold_indirect_ref (value);
1371 /* If the argument is a scalar, a pointer to an array or an allocatable,
1373 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1374 value = build_fold_indirect_ref (se->expr);
1376 /* For character(*), use the actual argument's descriptor. */
1377 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1378 value = build_fold_indirect_ref (se->expr);
1380 /* If the argument is an array descriptor, use it to determine
1381 information about the actual argument's shape. */
1382 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1383 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1385 /* Get the actual argument's descriptor. */
1386 desc = build_fold_indirect_ref (se->expr);
1388 /* Create the replacement variable. */
1389 tmp = gfc_conv_descriptor_data_get (desc);
1390 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1392 /* Use DESC to work out the upper bounds, strides and offset. */
1393 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1396 /* Otherwise we have a packed array. */
1397 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1399 new_sym->backend_decl = value;
1403 /* Called once all dummy argument mappings have been added to MAPPING,
1404 but before the mapping is used to evaluate expressions. Pre-evaluate
1405 the length of each argument, adding any initialization code to PRE and
1406 any finalization code to POST. */
1409 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1410 stmtblock_t * pre, stmtblock_t * post)
1412 gfc_interface_sym_mapping *sym;
1416 for (sym = mapping->syms; sym; sym = sym->next)
1417 if (sym->new->n.sym->ts.type == BT_CHARACTER
1418 && !sym->new->n.sym->ts.cl->backend_decl)
1420 expr = sym->new->n.sym->ts.cl->length;
1421 gfc_apply_interface_mapping_to_expr (mapping, expr);
1422 gfc_init_se (&se, NULL);
1423 gfc_conv_expr (&se, expr);
1425 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1426 gfc_add_block_to_block (pre, &se.pre);
1427 gfc_add_block_to_block (post, &se.post);
1429 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1434 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1438 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1439 gfc_constructor * c)
1441 for (; c; c = c->next)
1443 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1446 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1447 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1448 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1454 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1458 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1463 for (; ref; ref = ref->next)
1467 for (n = 0; n < ref->u.ar.dimen; n++)
1469 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1470 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1471 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1473 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1480 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1481 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1487 /* EXPR is a copy of an expression that appeared in the interface
1488 associated with MAPPING. Walk it recursively looking for references to
1489 dummy arguments that MAPPING maps to actual arguments. Replace each such
1490 reference with a reference to the associated actual argument. */
1493 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1496 gfc_interface_sym_mapping *sym;
1497 gfc_actual_arglist *actual;
1502 /* Copying an expression does not copy its length, so do that here. */
1503 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1505 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1506 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1509 /* Apply the mapping to any references. */
1510 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1512 /* ...and to the expression's symbol, if it has one. */
1514 for (sym = mapping->syms; sym; sym = sym->next)
1515 if (sym->old == expr->symtree->n.sym)
1516 expr->symtree = sym->new;
1518 /* ...and to subexpressions in expr->value. */
1519 switch (expr->expr_type)
1524 case EXPR_SUBSTRING:
1528 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1529 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1533 for (sym = mapping->syms; sym; sym = sym->next)
1534 if (sym->old == expr->value.function.esym)
1535 expr->value.function.esym = sym->new->n.sym;
1537 for (actual = expr->value.function.actual; actual; actual = actual->next)
1538 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1542 case EXPR_STRUCTURE:
1543 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1549 /* Evaluate interface expression EXPR using MAPPING. Store the result
1553 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1554 gfc_se * se, gfc_expr * expr)
1556 expr = gfc_copy_expr (expr);
1557 gfc_apply_interface_mapping_to_expr (mapping, expr);
1558 gfc_conv_expr (se, expr);
1559 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1560 gfc_free_expr (expr);
1563 /* Returns a reference to a temporary array into which a component of
1564 an actual argument derived type array is copied and then returned
1565 after the function call.
1566 TODO Get rid of this kludge, when array descriptors are capable of
1567 handling aliased arrays. */
1570 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
1586 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1588 gfc_init_se (&lse, NULL);
1589 gfc_init_se (&rse, NULL);
1591 /* Walk the argument expression. */
1592 rss = gfc_walk_expr (expr);
1594 gcc_assert (rss != gfc_ss_terminator);
1596 /* Initialize the scalarizer. */
1597 gfc_init_loopinfo (&loop);
1598 gfc_add_ss_to_loop (&loop, rss);
1600 /* Calculate the bounds of the scalarization. */
1601 gfc_conv_ss_startstride (&loop);
1603 /* Build an ss for the temporary. */
1604 base_type = gfc_typenode_for_spec (&expr->ts);
1605 if (GFC_ARRAY_TYPE_P (base_type)
1606 || GFC_DESCRIPTOR_TYPE_P (base_type))
1607 base_type = gfc_get_element_type (base_type);
1609 loop.temp_ss = gfc_get_ss ();;
1610 loop.temp_ss->type = GFC_SS_TEMP;
1611 loop.temp_ss->data.temp.type = base_type;
1613 if (expr->ts.type == BT_CHARACTER)
1614 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1616 loop.temp_ss->data.temp.dimen = loop.dimen;
1617 loop.temp_ss->next = gfc_ss_terminator;
1619 /* Associate the SS with the loop. */
1620 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1622 /* Setup the scalarizing loops. */
1623 gfc_conv_loop_setup (&loop);
1625 /* Pass the temporary descriptor back to the caller. */
1626 info = &loop.temp_ss->data.info;
1627 parmse->expr = info->descriptor;
1629 /* Setup the gfc_se structures. */
1630 gfc_copy_loopinfo_to_se (&lse, &loop);
1631 gfc_copy_loopinfo_to_se (&rse, &loop);
1634 lse.ss = loop.temp_ss;
1635 gfc_mark_ss_chain_used (rss, 1);
1636 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1638 /* Start the scalarized loop body. */
1639 gfc_start_scalarized_body (&loop, &body);
1641 /* Translate the expression. */
1642 gfc_conv_expr (&rse, expr);
1644 gfc_conv_tmp_array_ref (&lse);
1645 gfc_advance_se_ss_chain (&lse);
1647 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1648 gfc_add_expr_to_block (&body, tmp);
1650 gcc_assert (rse.ss == gfc_ss_terminator);
1652 gfc_trans_scalarizing_loops (&loop, &body);
1654 /* Add the post block after the second loop, so that any
1655 freeing of allocated memory is done at the right time. */
1656 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1658 /**********Copy the temporary back again.*********/
1660 gfc_init_se (&lse, NULL);
1661 gfc_init_se (&rse, NULL);
1663 /* Walk the argument expression. */
1664 lss = gfc_walk_expr (expr);
1665 rse.ss = loop.temp_ss;
1668 /* Initialize the scalarizer. */
1669 gfc_init_loopinfo (&loop2);
1670 gfc_add_ss_to_loop (&loop2, lss);
1672 /* Calculate the bounds of the scalarization. */
1673 gfc_conv_ss_startstride (&loop2);
1675 /* Setup the scalarizing loops. */
1676 gfc_conv_loop_setup (&loop2);
1678 gfc_copy_loopinfo_to_se (&lse, &loop2);
1679 gfc_copy_loopinfo_to_se (&rse, &loop2);
1681 gfc_mark_ss_chain_used (lss, 1);
1682 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1684 /* Declare the variable to hold the temporary offset and start the
1685 scalarized loop body. */
1686 offset = gfc_create_var (gfc_array_index_type, NULL);
1687 gfc_start_scalarized_body (&loop2, &body);
1689 /* Build the offsets for the temporary from the loop variables. The
1690 temporary array has lbounds of zero and strides of one in all
1691 dimensions, so this is very simple. The offset is only computed
1692 outside the innermost loop, so the overall transfer could be
1693 optimised further. */
1694 info = &rse.ss->data.info;
1696 tmp_index = gfc_index_zero_node;
1697 for (n = info->dimen - 1; n > 0; n--)
1700 tmp = rse.loop->loopvar[n];
1701 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1702 tmp, rse.loop->from[n]);
1703 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1706 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1707 rse.loop->to[n-1], rse.loop->from[n-1]);
1708 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1709 tmp_str, gfc_index_one_node);
1711 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1715 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1716 tmp_index, rse.loop->from[0]);
1717 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1719 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1720 rse.loop->loopvar[0], offset);
1722 /* Now use the offset for the reference. */
1723 tmp = build_fold_indirect_ref (info->data);
1724 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1726 if (expr->ts.type == BT_CHARACTER)
1727 rse.string_length = expr->ts.cl->backend_decl;
1729 gfc_conv_expr (&lse, expr);
1731 gcc_assert (lse.ss == gfc_ss_terminator);
1733 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1734 gfc_add_expr_to_block (&body, tmp);
1736 /* Generate the copying loops. */
1737 gfc_trans_scalarizing_loops (&loop2, &body);
1739 /* Wrap the whole thing up by adding the second loop to the post-block
1740 and following it by the post-block of the fist loop. In this way,
1741 if the temporary needs freeing, it is done after use! */
1742 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1743 gfc_add_block_to_block (&parmse->post, &loop2.post);
1745 gfc_add_block_to_block (&parmse->post, &loop.post);
1747 gfc_cleanup_loop (&loop);
1748 gfc_cleanup_loop (&loop2);
1750 /* Pass the string length to the argument expression. */
1751 if (expr->ts.type == BT_CHARACTER)
1752 parmse->string_length = expr->ts.cl->backend_decl;
1754 /* We want either the address for the data or the address of the descriptor,
1755 depending on the mode of passing array arguments. */
1757 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1759 parmse->expr = build_fold_addr_expr (parmse->expr);
1764 /* Is true if the last array reference is followed by a component reference. */
1767 is_aliased_array (gfc_expr * e)
1773 for (ref = e->ref; ref; ref = ref->next)
1775 if (ref->type == REF_ARRAY)
1778 if (ref->next == NULL && ref->type == REF_COMPONENT)
1784 /* Generate code for a procedure call. Note can return se->post != NULL.
1785 If se->direct_byref is set then se->expr contains the return parameter.
1786 Return nonzero, if the call has alternate specifiers. */
1789 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1790 gfc_actual_arglist * arg)
1792 gfc_interface_mapping mapping;
1805 gfc_formal_arglist *formal;
1806 int has_alternate_specifier = 0;
1807 bool need_interface_mapping;
1812 arglist = NULL_TREE;
1813 retargs = NULL_TREE;
1814 stringargs = NULL_TREE;
1820 if (!sym->attr.elemental)
1822 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1823 if (se->ss->useflags)
1825 gcc_assert (gfc_return_by_reference (sym)
1826 && sym->result->attr.dimension);
1827 gcc_assert (se->loop != NULL);
1829 /* Access the previously obtained result. */
1830 gfc_conv_tmp_array_ref (se);
1831 gfc_advance_se_ss_chain (se);
1835 info = &se->ss->data.info;
1840 gfc_init_interface_mapping (&mapping);
1841 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1842 && sym->ts.cl->length
1843 && sym->ts.cl->length->expr_type
1845 || sym->attr.dimension);
1846 formal = sym->formal;
1847 /* Evaluate the arguments. */
1848 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1850 if (arg->expr == NULL)
1853 if (se->ignore_optional)
1855 /* Some intrinsics have already been resolved to the correct
1859 else if (arg->label)
1861 has_alternate_specifier = 1;
1866 /* Pass a NULL pointer for an absent arg. */
1867 gfc_init_se (&parmse, NULL);
1868 parmse.expr = null_pointer_node;
1869 if (arg->missing_arg_type == BT_CHARACTER)
1870 parmse.string_length = convert (gfc_charlen_type_node,
1874 else if (se->ss && se->ss->useflags)
1876 /* An elemental function inside a scalarized loop. */
1877 gfc_init_se (&parmse, se);
1878 gfc_conv_expr_reference (&parmse, arg->expr);
1882 /* A scalar or transformational function. */
1883 gfc_init_se (&parmse, NULL);
1884 argss = gfc_walk_expr (arg->expr);
1886 if (argss == gfc_ss_terminator)
1888 gfc_conv_expr_reference (&parmse, arg->expr);
1889 if (formal && formal->sym->attr.pointer
1890 && arg->expr->expr_type != EXPR_NULL)
1892 /* Scalar pointer dummy args require an extra level of
1893 indirection. The null pointer already contains
1894 this level of indirection. */
1895 parmse.expr = build_fold_addr_expr (parmse.expr);
1900 /* If the procedure requires an explicit interface, the actual
1901 argument is passed according to the corresponding formal
1902 argument. If the corresponding formal argument is a POINTER,
1903 ALLOCATABLE or assumed shape, we do not use g77's calling
1904 convention, and pass the address of the array descriptor
1905 instead. Otherwise we use g77's calling convention. */
1907 f = (formal != NULL)
1908 && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
1909 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1910 f = f || !sym->attr.always_explicit;
1911 if (arg->expr->expr_type == EXPR_VARIABLE
1912 && is_aliased_array (arg->expr))
1913 /* The actual argument is a component reference to an
1914 array of derived types. In this case, the argument
1915 is converted to a temporary, which is passed and then
1916 written back after the procedure call. */
1917 gfc_conv_aliased_arg (&parmse, arg->expr, f);
1919 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1921 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
1922 allocated on entry, it must be deallocated. */
1923 if (formal && formal->sym->attr.allocatable
1924 && formal->sym->attr.intent == INTENT_OUT)
1926 tmp = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
1927 gfc_add_expr_to_block (&se->pre, tmp);
1933 if (formal && need_interface_mapping)
1934 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1936 gfc_add_block_to_block (&se->pre, &parmse.pre);
1937 gfc_add_block_to_block (&se->post, &parmse.post);
1939 /* Character strings are passed as two parameters, a length and a
1941 if (parmse.string_length != NULL_TREE)
1942 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1944 arglist = gfc_chainon_list (arglist, parmse.expr);
1946 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1949 if (ts.type == BT_CHARACTER)
1951 if (sym->ts.cl->length == NULL)
1953 /* Assumed character length results are not allowed by 5.1.1.5 of the
1954 standard and are trapped in resolve.c; except in the case of SPREAD
1955 (and other intrinsics?). In this case, we take the character length
1956 of the first argument for the result. */
1957 cl.backend_decl = TREE_VALUE (stringargs);
1961 /* Calculate the length of the returned string. */
1962 gfc_init_se (&parmse, NULL);
1963 if (need_interface_mapping)
1964 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1966 gfc_conv_expr (&parmse, sym->ts.cl->length);
1967 gfc_add_block_to_block (&se->pre, &parmse.pre);
1968 gfc_add_block_to_block (&se->post, &parmse.post);
1969 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1972 /* Set up a charlen structure for it. */
1977 len = cl.backend_decl;
1980 byref = gfc_return_by_reference (sym);
1983 if (se->direct_byref)
1984 retargs = gfc_chainon_list (retargs, se->expr);
1985 else if (sym->result->attr.dimension)
1987 gcc_assert (se->loop && info);
1989 /* Set the type of the array. */
1990 tmp = gfc_typenode_for_spec (&ts);
1991 info->dimen = se->loop->dimen;
1993 /* Evaluate the bounds of the result, if known. */
1994 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1996 /* Create a temporary to store the result. In case the function
1997 returns a pointer, the temporary will be a shallow copy and
1998 mustn't be deallocated. */
1999 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2000 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2001 false, !sym->attr.pointer, callee_alloc);
2003 /* Zero the first stride to indicate a temporary. */
2004 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
2005 gfc_add_modify_expr (&se->pre, tmp,
2006 convert (TREE_TYPE (tmp), integer_zero_node));
2008 /* Pass the temporary as the first argument. */
2009 tmp = info->descriptor;
2010 tmp = build_fold_addr_expr (tmp);
2011 retargs = gfc_chainon_list (retargs, tmp);
2013 else if (ts.type == BT_CHARACTER)
2015 /* Pass the string length. */
2016 type = gfc_get_character_type (ts.kind, ts.cl);
2017 type = build_pointer_type (type);
2019 /* Return an address to a char[0:len-1]* temporary for
2020 character pointers. */
2021 if (sym->attr.pointer || sym->attr.allocatable)
2023 /* Build char[0:len-1] * pstr. */
2024 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2025 build_int_cst (gfc_charlen_type_node, 1));
2026 tmp = build_range_type (gfc_array_index_type,
2027 gfc_index_zero_node, tmp);
2028 tmp = build_array_type (gfc_character1_type_node, tmp);
2029 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2031 /* Provide an address expression for the function arguments. */
2032 var = build_fold_addr_expr (var);
2035 var = gfc_conv_string_tmp (se, type, len);
2037 retargs = gfc_chainon_list (retargs, var);
2041 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2043 type = gfc_get_complex_type (ts.kind);
2044 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2045 retargs = gfc_chainon_list (retargs, var);
2048 /* Add the string length to the argument list. */
2049 if (ts.type == BT_CHARACTER)
2050 retargs = gfc_chainon_list (retargs, len);
2052 gfc_free_interface_mapping (&mapping);
2054 /* Add the return arguments. */
2055 arglist = chainon (retargs, arglist);
2057 /* Add the hidden string length parameters to the arguments. */
2058 arglist = chainon (arglist, stringargs);
2060 /* Generate the actual call. */
2061 gfc_conv_function_val (se, sym);
2062 /* If there are alternate return labels, function type should be
2063 integer. Can't modify the type in place though, since it can be shared
2064 with other functions. */
2065 if (has_alternate_specifier
2066 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2068 gcc_assert (! sym->attr.dummy);
2069 TREE_TYPE (sym->backend_decl)
2070 = build_function_type (integer_type_node,
2071 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2072 se->expr = build_fold_addr_expr (sym->backend_decl);
2075 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2076 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2077 arglist, NULL_TREE);
2079 /* If we have a pointer function, but we don't want a pointer, e.g.
2082 where f is pointer valued, we have to dereference the result. */
2083 if (!se->want_pointer && !byref && sym->attr.pointer)
2084 se->expr = build_fold_indirect_ref (se->expr);
2086 /* f2c calling conventions require a scalar default real function to
2087 return a double precision result. Convert this back to default
2088 real. We only care about the cases that can happen in Fortran 77.
2090 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2091 && sym->ts.kind == gfc_default_real_kind
2092 && !sym->attr.always_explicit)
2093 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2095 /* A pure function may still have side-effects - it may modify its
2097 TREE_SIDE_EFFECTS (se->expr) = 1;
2099 if (!sym->attr.pure)
2100 TREE_SIDE_EFFECTS (se->expr) = 1;
2105 /* Add the function call to the pre chain. There is no expression. */
2106 gfc_add_expr_to_block (&se->pre, se->expr);
2107 se->expr = NULL_TREE;
2109 if (!se->direct_byref)
2111 if (sym->attr.dimension)
2113 if (flag_bounds_check)
2115 /* Check the data pointer hasn't been modified. This would
2116 happen in a function returning a pointer. */
2117 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2118 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2120 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
2122 se->expr = info->descriptor;
2123 /* Bundle in the string length. */
2124 se->string_length = len;
2126 else if (sym->ts.type == BT_CHARACTER)
2128 /* Dereference for character pointer results. */
2129 if (sym->attr.pointer || sym->attr.allocatable)
2130 se->expr = build_fold_indirect_ref (var);
2134 se->string_length = len;
2138 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2139 se->expr = build_fold_indirect_ref (var);
2144 return has_alternate_specifier;
2148 /* Generate code to copy a string. */
2151 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
2152 tree slen, tree src)
2158 /* Deal with single character specially. */
2159 dsc = gfc_to_single_character (dlen, dest);
2160 ssc = gfc_to_single_character (slen, src);
2161 if (dsc != NULL_TREE && ssc != NULL_TREE)
2163 gfc_add_modify_expr (block, dsc, ssc);
2168 tmp = gfc_chainon_list (tmp, dlen);
2169 tmp = gfc_chainon_list (tmp, dest);
2170 tmp = gfc_chainon_list (tmp, slen);
2171 tmp = gfc_chainon_list (tmp, src);
2172 tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
2173 gfc_add_expr_to_block (block, tmp);
2177 /* Translate a statement function.
2178 The value of a statement function reference is obtained by evaluating the
2179 expression using the values of the actual arguments for the values of the
2180 corresponding dummy arguments. */
2183 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2187 gfc_formal_arglist *fargs;
2188 gfc_actual_arglist *args;
2191 gfc_saved_var *saved_vars;
2197 sym = expr->symtree->n.sym;
2198 args = expr->value.function.actual;
2199 gfc_init_se (&lse, NULL);
2200 gfc_init_se (&rse, NULL);
2203 for (fargs = sym->formal; fargs; fargs = fargs->next)
2205 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2206 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2208 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2210 /* Each dummy shall be specified, explicitly or implicitly, to be
2212 gcc_assert (fargs->sym->attr.dimension == 0);
2215 /* Create a temporary to hold the value. */
2216 type = gfc_typenode_for_spec (&fsym->ts);
2217 temp_vars[n] = gfc_create_var (type, fsym->name);
2219 if (fsym->ts.type == BT_CHARACTER)
2221 /* Copy string arguments. */
2224 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2225 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2227 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2228 tmp = gfc_build_addr_expr (build_pointer_type (type),
2231 gfc_conv_expr (&rse, args->expr);
2232 gfc_conv_string_parameter (&rse);
2233 gfc_add_block_to_block (&se->pre, &lse.pre);
2234 gfc_add_block_to_block (&se->pre, &rse.pre);
2236 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2238 gfc_add_block_to_block (&se->pre, &lse.post);
2239 gfc_add_block_to_block (&se->pre, &rse.post);
2243 /* For everything else, just evaluate the expression. */
2244 gfc_conv_expr (&lse, args->expr);
2246 gfc_add_block_to_block (&se->pre, &lse.pre);
2247 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2248 gfc_add_block_to_block (&se->pre, &lse.post);
2254 /* Use the temporary variables in place of the real ones. */
2255 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2256 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2258 gfc_conv_expr (se, sym->value);
2260 if (sym->ts.type == BT_CHARACTER)
2262 gfc_conv_const_charlen (sym->ts.cl);
2264 /* Force the expression to the correct length. */
2265 if (!INTEGER_CST_P (se->string_length)
2266 || tree_int_cst_lt (se->string_length,
2267 sym->ts.cl->backend_decl))
2269 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2270 tmp = gfc_create_var (type, sym->name);
2271 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2272 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2273 se->string_length, se->expr);
2276 se->string_length = sym->ts.cl->backend_decl;
2279 /* Restore the original variables. */
2280 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2281 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2282 gfc_free (saved_vars);
2286 /* Translate a function expression. */
2289 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2293 if (expr->value.function.isym)
2295 gfc_conv_intrinsic_function (se, expr);
2299 /* We distinguish statement functions from general functions to improve
2300 runtime performance. */
2301 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2303 gfc_conv_statement_function (se, expr);
2307 /* expr.value.function.esym is the resolved (specific) function symbol for
2308 most functions. However this isn't set for dummy procedures. */
2309 sym = expr->value.function.esym;
2311 sym = expr->symtree->n.sym;
2312 gfc_conv_function_call (se, sym, expr->value.function.actual);
2317 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2319 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2320 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2322 gfc_conv_tmp_array_ref (se);
2323 gfc_advance_se_ss_chain (se);
2327 /* Build a static initializer. EXPR is the expression for the initial value.
2328 The other parameters describe the variable of the component being
2329 initialized. EXPR may be null. */
2332 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2333 bool array, bool pointer)
2337 if (!(expr || pointer))
2342 /* Arrays need special handling. */
2344 return gfc_build_null_descriptor (type);
2346 return gfc_conv_array_initializer (type, expr);
2349 return fold_convert (type, null_pointer_node);
2355 gfc_init_se (&se, NULL);
2356 gfc_conv_structure (&se, expr, 1);
2360 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2363 gfc_init_se (&se, NULL);
2364 gfc_conv_constant (&se, expr);
2371 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2383 gfc_start_block (&block);
2385 /* Initialize the scalarizer. */
2386 gfc_init_loopinfo (&loop);
2388 gfc_init_se (&lse, NULL);
2389 gfc_init_se (&rse, NULL);
2392 rss = gfc_walk_expr (expr);
2393 if (rss == gfc_ss_terminator)
2395 /* The rhs is scalar. Add a ss for the expression. */
2396 rss = gfc_get_ss ();
2397 rss->next = gfc_ss_terminator;
2398 rss->type = GFC_SS_SCALAR;
2402 /* Create a SS for the destination. */
2403 lss = gfc_get_ss ();
2404 lss->type = GFC_SS_COMPONENT;
2406 lss->shape = gfc_get_shape (cm->as->rank);
2407 lss->next = gfc_ss_terminator;
2408 lss->data.info.dimen = cm->as->rank;
2409 lss->data.info.descriptor = dest;
2410 lss->data.info.data = gfc_conv_array_data (dest);
2411 lss->data.info.offset = gfc_conv_array_offset (dest);
2412 for (n = 0; n < cm->as->rank; n++)
2414 lss->data.info.dim[n] = n;
2415 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2416 lss->data.info.stride[n] = gfc_index_one_node;
2418 mpz_init (lss->shape[n]);
2419 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2420 cm->as->lower[n]->value.integer);
2421 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2424 /* Associate the SS with the loop. */
2425 gfc_add_ss_to_loop (&loop, lss);
2426 gfc_add_ss_to_loop (&loop, rss);
2428 /* Calculate the bounds of the scalarization. */
2429 gfc_conv_ss_startstride (&loop);
2431 /* Setup the scalarizing loops. */
2432 gfc_conv_loop_setup (&loop);
2434 /* Setup the gfc_se structures. */
2435 gfc_copy_loopinfo_to_se (&lse, &loop);
2436 gfc_copy_loopinfo_to_se (&rse, &loop);
2439 gfc_mark_ss_chain_used (rss, 1);
2441 gfc_mark_ss_chain_used (lss, 1);
2443 /* Start the scalarized loop body. */
2444 gfc_start_scalarized_body (&loop, &body);
2446 gfc_conv_tmp_array_ref (&lse);
2447 if (cm->ts.type == BT_CHARACTER)
2448 lse.string_length = cm->ts.cl->backend_decl;
2450 gfc_conv_expr (&rse, expr);
2452 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2453 gfc_add_expr_to_block (&body, tmp);
2455 gcc_assert (rse.ss == gfc_ss_terminator);
2457 /* Generate the copying loops. */
2458 gfc_trans_scalarizing_loops (&loop, &body);
2460 /* Wrap the whole thing up. */
2461 gfc_add_block_to_block (&block, &loop.pre);
2462 gfc_add_block_to_block (&block, &loop.post);
2464 for (n = 0; n < cm->as->rank; n++)
2465 mpz_clear (lss->shape[n]);
2466 gfc_free (lss->shape);
2468 gfc_cleanup_loop (&loop);
2470 return gfc_finish_block (&block);
2473 /* Assign a single component of a derived type constructor. */
2476 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2483 gfc_start_block (&block);
2486 gfc_init_se (&se, NULL);
2487 /* Pointer component. */
2490 /* Array pointer. */
2491 if (expr->expr_type == EXPR_NULL)
2492 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2495 rss = gfc_walk_expr (expr);
2496 se.direct_byref = 1;
2498 gfc_conv_expr_descriptor (&se, expr, rss);
2499 gfc_add_block_to_block (&block, &se.pre);
2500 gfc_add_block_to_block (&block, &se.post);
2505 /* Scalar pointers. */
2506 se.want_pointer = 1;
2507 gfc_conv_expr (&se, expr);
2508 gfc_add_block_to_block (&block, &se.pre);
2509 gfc_add_modify_expr (&block, dest,
2510 fold_convert (TREE_TYPE (dest), se.expr));
2511 gfc_add_block_to_block (&block, &se.post);
2514 else if (cm->dimension)
2516 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2517 gfc_add_expr_to_block (&block, tmp);
2519 else if (expr->ts.type == BT_DERIVED)
2521 /* Nested derived type. */
2522 tmp = gfc_trans_structure_assign (dest, expr);
2523 gfc_add_expr_to_block (&block, tmp);
2527 /* Scalar component. */
2530 gfc_init_se (&se, NULL);
2531 gfc_init_se (&lse, NULL);
2533 gfc_conv_expr (&se, expr);
2534 if (cm->ts.type == BT_CHARACTER)
2535 lse.string_length = cm->ts.cl->backend_decl;
2537 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2538 gfc_add_expr_to_block (&block, tmp);
2540 return gfc_finish_block (&block);
2543 /* Assign a derived type constructor to a variable. */
2546 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2554 gfc_start_block (&block);
2555 cm = expr->ts.derived->components;
2556 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2558 /* Skip absent members in default initializers. */
2562 field = cm->backend_decl;
2563 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2564 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2565 gfc_add_expr_to_block (&block, tmp);
2567 return gfc_finish_block (&block);
2570 /* Build an expression for a constructor. If init is nonzero then
2571 this is part of a static variable initializer. */
2574 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2581 VEC(constructor_elt,gc) *v = NULL;
2583 gcc_assert (se->ss == NULL);
2584 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2585 type = gfc_typenode_for_spec (&expr->ts);
2589 /* Create a temporary variable and fill it in. */
2590 se->expr = gfc_create_var (type, expr->ts.derived->name);
2591 tmp = gfc_trans_structure_assign (se->expr, expr);
2592 gfc_add_expr_to_block (&se->pre, tmp);
2596 cm = expr->ts.derived->components;
2597 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2599 /* Skip absent members in default initializers. */
2603 val = gfc_conv_initializer (c->expr, &cm->ts,
2604 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2606 /* Append it to the constructor list. */
2607 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2609 se->expr = build_constructor (type, v);
2613 /* Translate a substring expression. */
2616 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2622 gcc_assert (ref->type == REF_SUBSTRING);
2624 se->expr = gfc_build_string_const(expr->value.character.length,
2625 expr->value.character.string);
2626 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2627 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2629 gfc_conv_substring(se,ref,expr->ts.kind);
2633 /* Entry point for expression translation. Evaluates a scalar quantity.
2634 EXPR is the expression to be translated, and SE is the state structure if
2635 called from within the scalarized. */
2638 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2640 if (se->ss && se->ss->expr == expr
2641 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2643 /* Substitute a scalar expression evaluated outside the scalarization
2645 se->expr = se->ss->data.scalar.expr;
2646 se->string_length = se->ss->string_length;
2647 gfc_advance_se_ss_chain (se);
2651 switch (expr->expr_type)
2654 gfc_conv_expr_op (se, expr);
2658 gfc_conv_function_expr (se, expr);
2662 gfc_conv_constant (se, expr);
2666 gfc_conv_variable (se, expr);
2670 se->expr = null_pointer_node;
2673 case EXPR_SUBSTRING:
2674 gfc_conv_substring_expr (se, expr);
2677 case EXPR_STRUCTURE:
2678 gfc_conv_structure (se, expr, 0);
2682 gfc_conv_array_constructor_expr (se, expr);
2691 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2692 of an assignment. */
2694 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2696 gfc_conv_expr (se, expr);
2697 /* All numeric lvalues should have empty post chains. If not we need to
2698 figure out a way of rewriting an lvalue so that it has no post chain. */
2699 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2702 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2703 numeric expressions. Used for scalar values where inserting cleanup code
2706 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2710 gcc_assert (expr->ts.type != BT_CHARACTER);
2711 gfc_conv_expr (se, expr);
2714 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2715 gfc_add_modify_expr (&se->pre, val, se->expr);
2717 gfc_add_block_to_block (&se->pre, &se->post);
2721 /* Helper to translate and expression and convert it to a particular type. */
2723 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2725 gfc_conv_expr_val (se, expr);
2726 se->expr = convert (type, se->expr);
2730 /* Converts an expression so that it can be passed by reference. Scalar
2734 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2738 if (se->ss && se->ss->expr == expr
2739 && se->ss->type == GFC_SS_REFERENCE)
2741 se->expr = se->ss->data.scalar.expr;
2742 se->string_length = se->ss->string_length;
2743 gfc_advance_se_ss_chain (se);
2747 if (expr->ts.type == BT_CHARACTER)
2749 gfc_conv_expr (se, expr);
2750 gfc_conv_string_parameter (se);
2754 if (expr->expr_type == EXPR_VARIABLE)
2756 se->want_pointer = 1;
2757 gfc_conv_expr (se, expr);
2760 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2761 gfc_add_modify_expr (&se->pre, var, se->expr);
2762 gfc_add_block_to_block (&se->pre, &se->post);
2768 gfc_conv_expr (se, expr);
2770 /* Create a temporary var to hold the value. */
2771 if (TREE_CONSTANT (se->expr))
2773 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2774 DECL_INITIAL (var) = se->expr;
2779 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2780 gfc_add_modify_expr (&se->pre, var, se->expr);
2782 gfc_add_block_to_block (&se->pre, &se->post);
2784 /* Take the address of that value. */
2785 se->expr = build_fold_addr_expr (var);
2790 gfc_trans_pointer_assign (gfc_code * code)
2792 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2796 /* Generate code for a pointer assignment. */
2799 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2809 gfc_start_block (&block);
2811 gfc_init_se (&lse, NULL);
2813 lss = gfc_walk_expr (expr1);
2814 rss = gfc_walk_expr (expr2);
2815 if (lss == gfc_ss_terminator)
2817 /* Scalar pointers. */
2818 lse.want_pointer = 1;
2819 gfc_conv_expr (&lse, expr1);
2820 gcc_assert (rss == gfc_ss_terminator);
2821 gfc_init_se (&rse, NULL);
2822 rse.want_pointer = 1;
2823 gfc_conv_expr (&rse, expr2);
2824 gfc_add_block_to_block (&block, &lse.pre);
2825 gfc_add_block_to_block (&block, &rse.pre);
2826 gfc_add_modify_expr (&block, lse.expr,
2827 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2828 gfc_add_block_to_block (&block, &rse.post);
2829 gfc_add_block_to_block (&block, &lse.post);
2833 /* Array pointer. */
2834 gfc_conv_expr_descriptor (&lse, expr1, lss);
2835 switch (expr2->expr_type)
2838 /* Just set the data pointer to null. */
2839 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2843 /* Assign directly to the pointer's descriptor. */
2844 lse.direct_byref = 1;
2845 gfc_conv_expr_descriptor (&lse, expr2, rss);
2849 /* Assign to a temporary descriptor and then copy that
2850 temporary to the pointer. */
2852 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2855 lse.direct_byref = 1;
2856 gfc_conv_expr_descriptor (&lse, expr2, rss);
2857 gfc_add_modify_expr (&lse.pre, desc, tmp);
2860 gfc_add_block_to_block (&block, &lse.pre);
2861 gfc_add_block_to_block (&block, &lse.post);
2863 return gfc_finish_block (&block);
2867 /* Makes sure se is suitable for passing as a function string parameter. */
2868 /* TODO: Need to check all callers fo this function. It may be abused. */
2871 gfc_conv_string_parameter (gfc_se * se)
2875 if (TREE_CODE (se->expr) == STRING_CST)
2877 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2881 type = TREE_TYPE (se->expr);
2882 if (TYPE_STRING_FLAG (type))
2884 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2885 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2888 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2889 gcc_assert (se->string_length
2890 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2894 /* Generate code for assignment of scalar variables. Includes character
2898 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2902 gfc_init_block (&block);
2904 if (type == BT_CHARACTER)
2906 gcc_assert (lse->string_length != NULL_TREE
2907 && rse->string_length != NULL_TREE);
2909 gfc_conv_string_parameter (lse);
2910 gfc_conv_string_parameter (rse);
2912 gfc_add_block_to_block (&block, &lse->pre);
2913 gfc_add_block_to_block (&block, &rse->pre);
2915 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2916 rse->string_length, rse->expr);
2920 gfc_add_block_to_block (&block, &lse->pre);
2921 gfc_add_block_to_block (&block, &rse->pre);
2923 gfc_add_modify_expr (&block, lse->expr,
2924 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2927 gfc_add_block_to_block (&block, &lse->post);
2928 gfc_add_block_to_block (&block, &rse->post);
2930 return gfc_finish_block (&block);
2934 /* Try to translate array(:) = func (...), where func is a transformational
2935 array function, without using a temporary. Returns NULL is this isn't the
2939 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2944 bool seen_array_ref;
2946 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2947 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2950 /* Elemental functions don't need a temporary anyway. */
2951 if (expr2->value.function.esym != NULL
2952 && expr2->value.function.esym->attr.elemental)
2955 /* Fail if EXPR1 can't be expressed as a descriptor. */
2956 if (gfc_ref_needs_temporary_p (expr1->ref))
2959 /* Functions returning pointers need temporaries. */
2960 if (expr2->symtree->n.sym->attr.pointer
2961 || expr2->symtree->n.sym->attr.allocatable)
2964 /* Check that no LHS component references appear during an array
2965 reference. This is needed because we do not have the means to
2966 span any arbitrary stride with an array descriptor. This check
2967 is not needed for the rhs because the function result has to be
2969 seen_array_ref = false;
2970 for (ref = expr1->ref; ref; ref = ref->next)
2972 if (ref->type == REF_ARRAY)
2973 seen_array_ref= true;
2974 else if (ref->type == REF_COMPONENT && seen_array_ref)
2978 /* Check for a dependency. */
2979 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
2980 expr2->value.function.esym,
2981 expr2->value.function.actual))
2984 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2986 gcc_assert (expr2->value.function.isym
2987 || (gfc_return_by_reference (expr2->value.function.esym)
2988 && expr2->value.function.esym->result->attr.dimension));
2990 ss = gfc_walk_expr (expr1);
2991 gcc_assert (ss != gfc_ss_terminator);
2992 gfc_init_se (&se, NULL);
2993 gfc_start_block (&se.pre);
2994 se.want_pointer = 1;
2996 gfc_conv_array_parameter (&se, expr1, ss, 0);
2998 se.direct_byref = 1;
2999 se.ss = gfc_walk_expr (expr2);
3000 gcc_assert (se.ss != gfc_ss_terminator);
3001 gfc_conv_function_expr (&se, expr2);
3002 gfc_add_block_to_block (&se.pre, &se.post);
3004 return gfc_finish_block (&se.pre);
3008 /* Translate an assignment. Most of the code is concerned with
3009 setting up the scalarizer. */
3012 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
3017 gfc_ss *lss_section;
3024 /* Special case a single function returning an array. */
3025 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3027 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3032 /* Assignment of the form lhs = rhs. */
3033 gfc_start_block (&block);
3035 gfc_init_se (&lse, NULL);
3036 gfc_init_se (&rse, NULL);
3039 lss = gfc_walk_expr (expr1);
3041 if (lss != gfc_ss_terminator)
3043 /* The assignment needs scalarization. */
3046 /* Find a non-scalar SS from the lhs. */
3047 while (lss_section != gfc_ss_terminator
3048 && lss_section->type != GFC_SS_SECTION)
3049 lss_section = lss_section->next;
3051 gcc_assert (lss_section != gfc_ss_terminator);
3053 /* Initialize the scalarizer. */
3054 gfc_init_loopinfo (&loop);
3057 rss = gfc_walk_expr (expr2);
3058 if (rss == gfc_ss_terminator)
3060 /* The rhs is scalar. Add a ss for the expression. */
3061 rss = gfc_get_ss ();
3062 rss->next = gfc_ss_terminator;
3063 rss->type = GFC_SS_SCALAR;
3066 /* Associate the SS with the loop. */
3067 gfc_add_ss_to_loop (&loop, lss);
3068 gfc_add_ss_to_loop (&loop, rss);
3070 /* Calculate the bounds of the scalarization. */
3071 gfc_conv_ss_startstride (&loop);
3072 /* Resolve any data dependencies in the statement. */
3073 gfc_conv_resolve_dependencies (&loop, lss, rss);
3074 /* Setup the scalarizing loops. */
3075 gfc_conv_loop_setup (&loop);
3077 /* Setup the gfc_se structures. */
3078 gfc_copy_loopinfo_to_se (&lse, &loop);
3079 gfc_copy_loopinfo_to_se (&rse, &loop);
3082 gfc_mark_ss_chain_used (rss, 1);
3083 if (loop.temp_ss == NULL)
3086 gfc_mark_ss_chain_used (lss, 1);
3090 lse.ss = loop.temp_ss;
3091 gfc_mark_ss_chain_used (lss, 3);
3092 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3095 /* Start the scalarized loop body. */
3096 gfc_start_scalarized_body (&loop, &body);
3099 gfc_init_block (&body);
3101 /* Translate the expression. */
3102 gfc_conv_expr (&rse, expr2);
3104 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3106 gfc_conv_tmp_array_ref (&lse);
3107 gfc_advance_se_ss_chain (&lse);
3110 gfc_conv_expr (&lse, expr1);
3112 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3113 gfc_add_expr_to_block (&body, tmp);
3115 if (lss == gfc_ss_terminator)
3117 /* Use the scalar assignment as is. */
3118 gfc_add_block_to_block (&block, &body);
3122 gcc_assert (lse.ss == gfc_ss_terminator
3123 && rse.ss == gfc_ss_terminator);
3125 if (loop.temp_ss != NULL)
3127 gfc_trans_scalarized_loop_boundary (&loop, &body);
3129 /* We need to copy the temporary to the actual lhs. */
3130 gfc_init_se (&lse, NULL);
3131 gfc_init_se (&rse, NULL);
3132 gfc_copy_loopinfo_to_se (&lse, &loop);
3133 gfc_copy_loopinfo_to_se (&rse, &loop);
3135 rse.ss = loop.temp_ss;
3138 gfc_conv_tmp_array_ref (&rse);
3139 gfc_advance_se_ss_chain (&rse);
3140 gfc_conv_expr (&lse, expr1);
3142 gcc_assert (lse.ss == gfc_ss_terminator
3143 && rse.ss == gfc_ss_terminator);
3145 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3146 gfc_add_expr_to_block (&body, tmp);
3148 /* Generate the copying loops. */
3149 gfc_trans_scalarizing_loops (&loop, &body);
3151 /* Wrap the whole thing up. */
3152 gfc_add_block_to_block (&block, &loop.pre);
3153 gfc_add_block_to_block (&block, &loop.post);
3155 gfc_cleanup_loop (&loop);
3158 return gfc_finish_block (&block);
3162 gfc_trans_assign (gfc_code * code)
3164 return gfc_trans_assignment (code->expr, code->expr2);