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)
300 sym = expr->symtree->n.sym;
303 /* Check that something hasn't gone horribly wrong. */
304 gcc_assert (se->ss != gfc_ss_terminator);
305 gcc_assert (se->ss->expr == expr);
307 /* A scalarized term. We already know the descriptor. */
308 se->expr = se->ss->data.info.descriptor;
309 se->string_length = se->ss->string_length;
310 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
311 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
316 tree se_expr = NULL_TREE;
318 se->expr = gfc_get_symbol_decl (sym);
320 /* Special case for assigning the return value of a function.
321 Self recursive functions must have an explicit return value. */
322 if (se->expr == current_function_decl && sym->attr.function
323 && (sym->result == sym))
324 se_expr = gfc_get_fake_result_decl (sym);
326 /* Similarly for alternate entry points. */
327 else if (sym->attr.function && sym->attr.entry
328 && (sym->result == sym)
329 && sym->ns->proc_name->backend_decl == current_function_decl)
331 gfc_entry_list *el = NULL;
333 for (el = sym->ns->entries; el; el = el->next)
336 se_expr = gfc_get_fake_result_decl (sym);
341 else if (sym->attr.result
342 && sym->ns->proc_name->backend_decl == current_function_decl
343 && sym->ns->proc_name->attr.entry_master
344 && !gfc_return_by_reference (sym->ns->proc_name))
345 se_expr = gfc_get_fake_result_decl (sym);
350 /* Procedure actual arguments. */
351 else if (sym->attr.flavor == FL_PROCEDURE
352 && se->expr != current_function_decl)
354 gcc_assert (se->want_pointer);
355 if (!sym->attr.dummy)
357 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
358 se->expr = build_fold_addr_expr (se->expr);
364 /* Dereference the expression, where needed. Since characters
365 are entirely different from other types, they are treated
367 if (sym->ts.type == BT_CHARACTER)
369 /* Dereference character pointer dummy arguments
371 if ((sym->attr.pointer || sym->attr.allocatable)
373 || sym->attr.function
374 || sym->attr.result))
375 se->expr = build_fold_indirect_ref (se->expr);
379 /* Dereference non-character scalar dummy arguments. */
380 if (sym->attr.dummy && !sym->attr.dimension)
381 se->expr = build_fold_indirect_ref (se->expr);
383 /* Dereference scalar hidden result. */
384 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
385 && (sym->attr.function || sym->attr.result)
386 && !sym->attr.dimension && !sym->attr.pointer)
387 se->expr = build_fold_indirect_ref (se->expr);
389 /* Dereference non-character pointer variables.
390 These must be dummies, results, or scalars. */
391 if ((sym->attr.pointer || sym->attr.allocatable)
393 || sym->attr.function
395 || !sym->attr.dimension))
396 se->expr = build_fold_indirect_ref (se->expr);
402 /* For character variables, also get the length. */
403 if (sym->ts.type == BT_CHARACTER)
405 /* If the character length of an entry isn't set, get the length from
406 the master function instead. */
407 if (sym->attr.entry && !sym->ts.cl->backend_decl)
408 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
410 se->string_length = sym->ts.cl->backend_decl;
411 gcc_assert (se->string_length);
419 /* Return the descriptor if that's what we want and this is an array
420 section reference. */
421 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
423 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
424 /* Return the descriptor for array pointers and allocations. */
426 && ref->next == NULL && (se->descriptor_only))
429 gfc_conv_array_ref (se, &ref->u.ar);
430 /* Return a pointer to an element. */
434 gfc_conv_component_ref (se, ref);
438 gfc_conv_substring (se, ref, expr->ts.kind);
447 /* Pointer assignment, allocation or pass by reference. Arrays are handled
449 if (se->want_pointer)
451 if (expr->ts.type == BT_CHARACTER)
452 gfc_conv_string_parameter (se);
454 se->expr = build_fold_addr_expr (se->expr);
459 /* Unary ops are easy... Or they would be if ! was a valid op. */
462 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
467 gcc_assert (expr->ts.type != BT_CHARACTER);
468 /* Initialize the operand. */
469 gfc_init_se (&operand, se);
470 gfc_conv_expr_val (&operand, expr->value.op.op1);
471 gfc_add_block_to_block (&se->pre, &operand.pre);
473 type = gfc_typenode_for_spec (&expr->ts);
475 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
476 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
477 All other unary operators have an equivalent GIMPLE unary operator. */
478 if (code == TRUTH_NOT_EXPR)
479 se->expr = build2 (EQ_EXPR, type, operand.expr,
480 convert (type, integer_zero_node));
482 se->expr = build1 (code, type, operand.expr);
486 /* Expand power operator to optimal multiplications when a value is raised
487 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
488 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
489 Programming", 3rd Edition, 1998. */
491 /* This code is mostly duplicated from expand_powi in the backend.
492 We establish the "optimal power tree" lookup table with the defined size.
493 The items in the table are the exponents used to calculate the index
494 exponents. Any integer n less than the value can get an "addition chain",
495 with the first node being one. */
496 #define POWI_TABLE_SIZE 256
498 /* The table is from builtins.c. */
499 static const unsigned char powi_table[POWI_TABLE_SIZE] =
501 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
502 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
503 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
504 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
505 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
506 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
507 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
508 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
509 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
510 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
511 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
512 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
513 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
514 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
515 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
516 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
517 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
518 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
519 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
520 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
521 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
522 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
523 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
524 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
525 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
526 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
527 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
528 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
529 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
530 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
531 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
532 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
535 /* If n is larger than lookup table's max index, we use the "window
537 #define POWI_WINDOW_SIZE 3
539 /* Recursive function to expand the power operator. The temporary
540 values are put in tmpvar. The function returns tmpvar[1] ** n. */
542 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
549 if (n < POWI_TABLE_SIZE)
554 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
555 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
559 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
560 op0 = gfc_conv_powi (se, n - digit, tmpvar);
561 op1 = gfc_conv_powi (se, digit, tmpvar);
565 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
569 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
570 tmp = gfc_evaluate_now (tmp, &se->pre);
572 if (n < POWI_TABLE_SIZE)
579 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
580 return 1. Else return 0 and a call to runtime library functions
581 will have to be built. */
583 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
588 tree vartmp[POWI_TABLE_SIZE];
592 type = TREE_TYPE (lhs);
593 n = abs (TREE_INT_CST_LOW (rhs));
594 sgn = tree_int_cst_sgn (rhs);
596 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
597 && (n > 2 || n < -1))
603 se->expr = gfc_build_const (type, integer_one_node);
606 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
607 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
609 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
610 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
611 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
612 convert (TREE_TYPE (lhs), integer_one_node));
615 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
618 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
619 se->expr = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_one_node),
621 convert (type, integer_zero_node));
625 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
626 tmp = build3 (COND_EXPR, type, tmp,
627 convert (type, integer_minus_one_node),
628 convert (type, integer_zero_node));
629 se->expr = build3 (COND_EXPR, type, cond,
630 convert (type, integer_one_node),
635 memset (vartmp, 0, sizeof (vartmp));
639 tmp = gfc_build_const (type, integer_one_node);
640 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
643 se->expr = gfc_conv_powi (se, n, vartmp);
649 /* Power op (**). Constant integer exponent has special handling. */
652 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
654 tree gfc_int4_type_node;
662 gfc_init_se (&lse, se);
663 gfc_conv_expr_val (&lse, expr->value.op.op1);
664 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
665 gfc_add_block_to_block (&se->pre, &lse.pre);
667 gfc_init_se (&rse, se);
668 gfc_conv_expr_val (&rse, expr->value.op.op2);
669 gfc_add_block_to_block (&se->pre, &rse.pre);
671 if (expr->value.op.op2->ts.type == BT_INTEGER
672 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
673 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
676 gfc_int4_type_node = gfc_get_int_type (4);
678 kind = expr->value.op.op1->ts.kind;
679 switch (expr->value.op.op2->ts.type)
682 ikind = expr->value.op.op2->ts.kind;
687 rse.expr = convert (gfc_int4_type_node, rse.expr);
709 if (expr->value.op.op1->ts.type == BT_INTEGER)
710 lse.expr = convert (gfc_int4_type_node, lse.expr);
735 switch (expr->value.op.op1->ts.type)
738 if (kind == 3) /* Case 16 was not handled properly above. */
740 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
744 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
748 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
760 fndecl = built_in_decls[BUILT_IN_POWF];
763 fndecl = built_in_decls[BUILT_IN_POW];
767 fndecl = built_in_decls[BUILT_IN_POWL];
778 fndecl = gfor_fndecl_math_cpowf;
781 fndecl = gfor_fndecl_math_cpow;
784 fndecl = gfor_fndecl_math_cpowl10;
787 fndecl = gfor_fndecl_math_cpowl16;
799 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
800 tmp = gfc_chainon_list (tmp, rse.expr);
801 se->expr = build_function_call_expr (fndecl, tmp);
805 /* Generate code to allocate a string temporary. */
808 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
814 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
816 if (gfc_can_put_var_on_stack (len))
818 /* Create a temporary variable to hold the result. */
819 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
820 convert (gfc_charlen_type_node, integer_one_node));
821 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
822 tmp = build_array_type (gfc_character1_type_node, tmp);
823 var = gfc_create_var (tmp, "str");
824 var = gfc_build_addr_expr (type, var);
828 /* Allocate a temporary to hold the result. */
829 var = gfc_create_var (type, "pstr");
830 args = gfc_chainon_list (NULL_TREE, len);
831 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
832 tmp = convert (type, tmp);
833 gfc_add_modify_expr (&se->pre, var, tmp);
835 /* Free the temporary afterwards. */
836 tmp = convert (pvoid_type_node, var);
837 args = gfc_chainon_list (NULL_TREE, tmp);
838 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
839 gfc_add_expr_to_block (&se->post, tmp);
846 /* Handle a string concatenation operation. A temporary will be allocated to
850 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
860 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
861 && expr->value.op.op2->ts.type == BT_CHARACTER);
863 gfc_init_se (&lse, se);
864 gfc_conv_expr (&lse, expr->value.op.op1);
865 gfc_conv_string_parameter (&lse);
866 gfc_init_se (&rse, se);
867 gfc_conv_expr (&rse, expr->value.op.op2);
868 gfc_conv_string_parameter (&rse);
870 gfc_add_block_to_block (&se->pre, &lse.pre);
871 gfc_add_block_to_block (&se->pre, &rse.pre);
873 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
874 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
875 if (len == NULL_TREE)
877 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
878 lse.string_length, rse.string_length);
881 type = build_pointer_type (type);
883 var = gfc_conv_string_tmp (se, type, len);
885 /* Do the actual concatenation. */
887 args = gfc_chainon_list (args, len);
888 args = gfc_chainon_list (args, var);
889 args = gfc_chainon_list (args, lse.string_length);
890 args = gfc_chainon_list (args, lse.expr);
891 args = gfc_chainon_list (args, rse.string_length);
892 args = gfc_chainon_list (args, rse.expr);
893 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
894 gfc_add_expr_to_block (&se->pre, tmp);
896 /* Add the cleanup for the operands. */
897 gfc_add_block_to_block (&se->pre, &rse.post);
898 gfc_add_block_to_block (&se->pre, &lse.post);
901 se->string_length = len;
904 /* Translates an op expression. Common (binary) cases are handled by this
905 function, others are passed on. Recursion is used in either case.
906 We use the fact that (op1.ts == op2.ts) (except for the power
908 Operators need no special handling for scalarized expressions as long as
909 they call gfc_conv_simple_val to get their operands.
910 Character strings get special handling. */
913 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
925 switch (expr->value.op.operator)
927 case INTRINSIC_UPLUS:
928 gfc_conv_expr (se, expr->value.op.op1);
931 case INTRINSIC_UMINUS:
932 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
936 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
943 case INTRINSIC_MINUS:
947 case INTRINSIC_TIMES:
951 case INTRINSIC_DIVIDE:
952 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
953 an integer, we must round towards zero, so we use a
955 if (expr->ts.type == BT_INTEGER)
956 code = TRUNC_DIV_EXPR;
961 case INTRINSIC_POWER:
962 gfc_conv_power_op (se, expr);
965 case INTRINSIC_CONCAT:
966 gfc_conv_concat_op (se, expr);
970 code = TRUTH_ANDIF_EXPR;
975 code = TRUTH_ORIF_EXPR;
979 /* EQV and NEQV only work on logicals, but since we represent them
980 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1019 case INTRINSIC_USER:
1020 case INTRINSIC_ASSIGN:
1021 /* These should be converted into function calls by the frontend. */
1025 fatal_error ("Unknown intrinsic op");
1029 /* The only exception to this is **, which is handled separately anyway. */
1030 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1032 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1036 gfc_init_se (&lse, se);
1037 gfc_conv_expr (&lse, expr->value.op.op1);
1038 gfc_add_block_to_block (&se->pre, &lse.pre);
1041 gfc_init_se (&rse, se);
1042 gfc_conv_expr (&rse, expr->value.op.op2);
1043 gfc_add_block_to_block (&se->pre, &rse.pre);
1047 gfc_conv_string_parameter (&lse);
1048 gfc_conv_string_parameter (&rse);
1050 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1051 rse.string_length, rse.expr);
1052 rse.expr = integer_zero_node;
1053 gfc_add_block_to_block (&lse.post, &rse.post);
1056 type = gfc_typenode_for_spec (&expr->ts);
1060 /* The result of logical ops is always boolean_type_node. */
1061 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1062 se->expr = convert (type, tmp);
1065 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1067 /* Add the post blocks. */
1068 gfc_add_block_to_block (&se->post, &rse.post);
1069 gfc_add_block_to_block (&se->post, &lse.post);
1072 /* If a string's length is one, we convert it to a single character. */
1075 gfc_to_single_character (tree len, tree str)
1077 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1079 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1080 && TREE_INT_CST_HIGH (len) == 0)
1082 str = fold_convert (pchar_type_node, str);
1083 return build_fold_indirect_ref (str);
1089 /* Compare two strings. If they are all single characters, the result is the
1090 subtraction of them. Otherwise, we build a library call. */
1093 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1100 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1101 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1103 type = gfc_get_int_type (gfc_default_integer_kind);
1105 sc1 = gfc_to_single_character (len1, str1);
1106 sc2 = gfc_to_single_character (len2, str2);
1108 /* Deal with single character specially. */
1109 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1111 sc1 = fold_convert (type, sc1);
1112 sc2 = fold_convert (type, sc2);
1113 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1118 tmp = gfc_chainon_list (tmp, len1);
1119 tmp = gfc_chainon_list (tmp, str1);
1120 tmp = gfc_chainon_list (tmp, len2);
1121 tmp = gfc_chainon_list (tmp, str2);
1123 /* Build a call for the comparison. */
1124 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1131 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1135 if (sym->attr.dummy)
1137 tmp = gfc_get_symbol_decl (sym);
1138 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1139 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1143 if (!sym->backend_decl)
1144 sym->backend_decl = gfc_get_extern_function_decl (sym);
1146 tmp = sym->backend_decl;
1147 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1149 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1150 tmp = build_fold_addr_expr (tmp);
1157 /* Initialize MAPPING. */
1160 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1162 mapping->syms = NULL;
1163 mapping->charlens = NULL;
1167 /* Free all memory held by MAPPING (but not MAPPING itself). */
1170 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1172 gfc_interface_sym_mapping *sym;
1173 gfc_interface_sym_mapping *nextsym;
1175 gfc_charlen *nextcl;
1177 for (sym = mapping->syms; sym; sym = nextsym)
1179 nextsym = sym->next;
1180 gfc_free_symbol (sym->new->n.sym);
1181 gfc_free (sym->new);
1184 for (cl = mapping->charlens; cl; cl = nextcl)
1187 gfc_free_expr (cl->length);
1193 /* Return a copy of gfc_charlen CL. Add the returned structure to
1194 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1196 static gfc_charlen *
1197 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1202 new = gfc_get_charlen ();
1203 new->next = mapping->charlens;
1204 new->length = gfc_copy_expr (cl->length);
1206 mapping->charlens = new;
1211 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1212 array variable that can be used as the actual argument for dummy
1213 argument SYM. Add any initialization code to BLOCK. PACKED is as
1214 for gfc_get_nodesc_array_type and DATA points to the first element
1215 in the passed array. */
1218 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1219 int packed, tree data)
1224 type = gfc_typenode_for_spec (&sym->ts);
1225 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1227 var = gfc_create_var (type, "ifm");
1228 gfc_add_modify_expr (block, var, fold_convert (type, data));
1234 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1235 and offset of descriptorless array type TYPE given that it has the same
1236 size as DESC. Add any set-up code to BLOCK. */
1239 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1246 offset = gfc_index_zero_node;
1247 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1249 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1250 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1252 dim = gfc_rank_cst[n];
1253 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1254 gfc_conv_descriptor_ubound (desc, dim),
1255 gfc_conv_descriptor_lbound (desc, dim));
1256 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1257 GFC_TYPE_ARRAY_LBOUND (type, n),
1259 tmp = gfc_evaluate_now (tmp, block);
1260 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1262 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1263 GFC_TYPE_ARRAY_LBOUND (type, n),
1264 GFC_TYPE_ARRAY_STRIDE (type, n));
1265 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1267 offset = gfc_evaluate_now (offset, block);
1268 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1272 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1273 in SE. The caller may still use se->expr and se->string_length after
1274 calling this function. */
1277 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1278 gfc_symbol * sym, gfc_se * se)
1280 gfc_interface_sym_mapping *sm;
1284 gfc_symbol *new_sym;
1286 gfc_symtree *new_symtree;
1288 /* Create a new symbol to represent the actual argument. */
1289 new_sym = gfc_new_symbol (sym->name, NULL);
1290 new_sym->ts = sym->ts;
1291 new_sym->attr.referenced = 1;
1292 new_sym->attr.dimension = sym->attr.dimension;
1293 new_sym->attr.pointer = sym->attr.pointer;
1294 new_sym->attr.flavor = sym->attr.flavor;
1296 /* Create a fake symtree for it. */
1298 new_symtree = gfc_new_symtree (&root, sym->name);
1299 new_symtree->n.sym = new_sym;
1300 gcc_assert (new_symtree == root);
1302 /* Create a dummy->actual mapping. */
1303 sm = gfc_getmem (sizeof (*sm));
1304 sm->next = mapping->syms;
1306 sm->new = new_symtree;
1309 /* Stabilize the argument's value. */
1310 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1312 if (sym->ts.type == BT_CHARACTER)
1314 /* Create a copy of the dummy argument's length. */
1315 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1317 /* If the length is specified as "*", record the length that
1318 the caller is passing. We should use the callee's length
1319 in all other cases. */
1320 if (!new_sym->ts.cl->length)
1322 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1323 new_sym->ts.cl->backend_decl = se->string_length;
1327 /* Use the passed value as-is if the argument is a function. */
1328 if (sym->attr.flavor == FL_PROCEDURE)
1331 /* If the argument is either a string or a pointer to a string,
1332 convert it to a boundless character type. */
1333 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1335 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1336 tmp = build_pointer_type (tmp);
1337 if (sym->attr.pointer)
1338 tmp = build_pointer_type (tmp);
1340 value = fold_convert (tmp, se->expr);
1341 if (sym->attr.pointer)
1342 value = build_fold_indirect_ref (value);
1345 /* If the argument is a scalar or a pointer to an array, dereference it. */
1346 else if (!sym->attr.dimension || sym->attr.pointer)
1347 value = build_fold_indirect_ref (se->expr);
1349 /* If the argument is an array descriptor, use it to determine
1350 information about the actual argument's shape. */
1351 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1352 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1354 /* Get the actual argument's descriptor. */
1355 desc = build_fold_indirect_ref (se->expr);
1357 /* Create the replacement variable. */
1358 tmp = gfc_conv_descriptor_data_get (desc);
1359 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1361 /* Use DESC to work out the upper bounds, strides and offset. */
1362 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1365 /* Otherwise we have a packed array. */
1366 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1368 new_sym->backend_decl = value;
1372 /* Called once all dummy argument mappings have been added to MAPPING,
1373 but before the mapping is used to evaluate expressions. Pre-evaluate
1374 the length of each argument, adding any initialization code to PRE and
1375 any finalization code to POST. */
1378 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1379 stmtblock_t * pre, stmtblock_t * post)
1381 gfc_interface_sym_mapping *sym;
1385 for (sym = mapping->syms; sym; sym = sym->next)
1386 if (sym->new->n.sym->ts.type == BT_CHARACTER
1387 && !sym->new->n.sym->ts.cl->backend_decl)
1389 expr = sym->new->n.sym->ts.cl->length;
1390 gfc_apply_interface_mapping_to_expr (mapping, expr);
1391 gfc_init_se (&se, NULL);
1392 gfc_conv_expr (&se, expr);
1394 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1395 gfc_add_block_to_block (pre, &se.pre);
1396 gfc_add_block_to_block (post, &se.post);
1398 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1403 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1407 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1408 gfc_constructor * c)
1410 for (; c; c = c->next)
1412 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1415 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1416 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1417 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1423 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1427 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1432 for (; ref; ref = ref->next)
1436 for (n = 0; n < ref->u.ar.dimen; n++)
1438 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1439 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1440 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1442 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1449 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1450 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1456 /* EXPR is a copy of an expression that appeared in the interface
1457 associated with MAPPING. Walk it recursively looking for references to
1458 dummy arguments that MAPPING maps to actual arguments. Replace each such
1459 reference with a reference to the associated actual argument. */
1462 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1465 gfc_interface_sym_mapping *sym;
1466 gfc_actual_arglist *actual;
1471 /* Copying an expression does not copy its length, so do that here. */
1472 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1474 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1475 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1478 /* Apply the mapping to any references. */
1479 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1481 /* ...and to the expression's symbol, if it has one. */
1483 for (sym = mapping->syms; sym; sym = sym->next)
1484 if (sym->old == expr->symtree->n.sym)
1485 expr->symtree = sym->new;
1487 /* ...and to subexpressions in expr->value. */
1488 switch (expr->expr_type)
1493 case EXPR_SUBSTRING:
1497 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1498 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1502 for (sym = mapping->syms; sym; sym = sym->next)
1503 if (sym->old == expr->value.function.esym)
1504 expr->value.function.esym = sym->new->n.sym;
1506 for (actual = expr->value.function.actual; actual; actual = actual->next)
1507 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1511 case EXPR_STRUCTURE:
1512 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1518 /* Evaluate interface expression EXPR using MAPPING. Store the result
1522 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1523 gfc_se * se, gfc_expr * expr)
1525 expr = gfc_copy_expr (expr);
1526 gfc_apply_interface_mapping_to_expr (mapping, expr);
1527 gfc_conv_expr (se, expr);
1528 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1529 gfc_free_expr (expr);
1532 /* Returns a reference to a temporary array into which a component of
1533 an actual argument derived type array is copied and then returned
1534 after the function call.
1535 TODO Get rid of this kludge, when array descriptors are capable of
1536 handling aliased arrays. */
1539 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
1555 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1557 gfc_init_se (&lse, NULL);
1558 gfc_init_se (&rse, NULL);
1560 /* Walk the argument expression. */
1561 rss = gfc_walk_expr (expr);
1563 gcc_assert (rss != gfc_ss_terminator);
1565 /* Initialize the scalarizer. */
1566 gfc_init_loopinfo (&loop);
1567 gfc_add_ss_to_loop (&loop, rss);
1569 /* Calculate the bounds of the scalarization. */
1570 gfc_conv_ss_startstride (&loop);
1572 /* Build an ss for the temporary. */
1573 base_type = gfc_typenode_for_spec (&expr->ts);
1574 if (GFC_ARRAY_TYPE_P (base_type)
1575 || GFC_DESCRIPTOR_TYPE_P (base_type))
1576 base_type = gfc_get_element_type (base_type);
1578 loop.temp_ss = gfc_get_ss ();;
1579 loop.temp_ss->type = GFC_SS_TEMP;
1580 loop.temp_ss->data.temp.type = base_type;
1582 if (expr->ts.type == BT_CHARACTER)
1583 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1585 loop.temp_ss->data.temp.dimen = loop.dimen;
1586 loop.temp_ss->next = gfc_ss_terminator;
1588 /* Associate the SS with the loop. */
1589 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1591 /* Setup the scalarizing loops. */
1592 gfc_conv_loop_setup (&loop);
1594 /* Pass the temporary descriptor back to the caller. */
1595 info = &loop.temp_ss->data.info;
1596 parmse->expr = info->descriptor;
1598 /* Setup the gfc_se structures. */
1599 gfc_copy_loopinfo_to_se (&lse, &loop);
1600 gfc_copy_loopinfo_to_se (&rse, &loop);
1603 lse.ss = loop.temp_ss;
1604 gfc_mark_ss_chain_used (rss, 1);
1605 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1607 /* Start the scalarized loop body. */
1608 gfc_start_scalarized_body (&loop, &body);
1610 /* Translate the expression. */
1611 gfc_conv_expr (&rse, expr);
1613 gfc_conv_tmp_array_ref (&lse);
1614 gfc_advance_se_ss_chain (&lse);
1616 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1617 gfc_add_expr_to_block (&body, tmp);
1619 gcc_assert (rse.ss == gfc_ss_terminator);
1621 gfc_trans_scalarizing_loops (&loop, &body);
1623 /* Add the post block after the second loop, so that any
1624 freeing of allocated memory is done at the right time. */
1625 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1627 /**********Copy the temporary back again.*********/
1629 gfc_init_se (&lse, NULL);
1630 gfc_init_se (&rse, NULL);
1632 /* Walk the argument expression. */
1633 lss = gfc_walk_expr (expr);
1634 rse.ss = loop.temp_ss;
1637 /* Initialize the scalarizer. */
1638 gfc_init_loopinfo (&loop2);
1639 gfc_add_ss_to_loop (&loop2, lss);
1641 /* Calculate the bounds of the scalarization. */
1642 gfc_conv_ss_startstride (&loop2);
1644 /* Setup the scalarizing loops. */
1645 gfc_conv_loop_setup (&loop2);
1647 gfc_copy_loopinfo_to_se (&lse, &loop2);
1648 gfc_copy_loopinfo_to_se (&rse, &loop2);
1650 gfc_mark_ss_chain_used (lss, 1);
1651 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1653 /* Declare the variable to hold the temporary offset and start the
1654 scalarized loop body. */
1655 offset = gfc_create_var (gfc_array_index_type, NULL);
1656 gfc_start_scalarized_body (&loop2, &body);
1658 /* Build the offsets for the temporary from the loop variables. The
1659 temporary array has lbounds of zero and strides of one in all
1660 dimensions, so this is very simple. The offset is only computed
1661 outside the innermost loop, so the overall transfer could be
1662 optimised further. */
1663 info = &rse.ss->data.info;
1665 tmp_index = gfc_index_zero_node;
1666 for (n = info->dimen - 1; n > 0; n--)
1669 tmp = rse.loop->loopvar[n];
1670 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1671 tmp, rse.loop->from[n]);
1672 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1675 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1676 rse.loop->to[n-1], rse.loop->from[n-1]);
1677 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1678 tmp_str, gfc_index_one_node);
1680 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1684 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1685 tmp_index, rse.loop->from[0]);
1686 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1688 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1689 rse.loop->loopvar[0], offset);
1691 /* Now use the offset for the reference. */
1692 tmp = build_fold_indirect_ref (info->data);
1693 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1695 if (expr->ts.type == BT_CHARACTER)
1696 rse.string_length = expr->ts.cl->backend_decl;
1698 gfc_conv_expr (&lse, expr);
1700 gcc_assert (lse.ss == gfc_ss_terminator);
1702 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1703 gfc_add_expr_to_block (&body, tmp);
1705 /* Generate the copying loops. */
1706 gfc_trans_scalarizing_loops (&loop2, &body);
1708 /* Wrap the whole thing up by adding the second loop to the post-block
1709 and following it by the post-block of the fist loop. In this way,
1710 if the temporary needs freeing, it is done after use! */
1711 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1712 gfc_add_block_to_block (&parmse->post, &loop2.post);
1714 gfc_add_block_to_block (&parmse->post, &loop.post);
1716 gfc_cleanup_loop (&loop);
1717 gfc_cleanup_loop (&loop2);
1719 /* Pass the string length to the argument expression. */
1720 if (expr->ts.type == BT_CHARACTER)
1721 parmse->string_length = expr->ts.cl->backend_decl;
1723 /* We want either the address for the data or the address of the descriptor,
1724 depending on the mode of passing array arguments. */
1726 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1728 parmse->expr = build_fold_addr_expr (parmse->expr);
1733 /* Is true if the last array reference is followed by a component reference. */
1736 is_aliased_array (gfc_expr * e)
1742 for (ref = e->ref; ref; ref = ref->next)
1744 if (ref->type == REF_ARRAY)
1747 if (ref->next == NULL && ref->type == REF_COMPONENT)
1753 /* Generate code for a procedure call. Note can return se->post != NULL.
1754 If se->direct_byref is set then se->expr contains the return parameter.
1755 Return nonzero, if the call has alternate specifiers. */
1758 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1759 gfc_actual_arglist * arg)
1761 gfc_interface_mapping mapping;
1774 gfc_formal_arglist *formal;
1775 int has_alternate_specifier = 0;
1776 bool need_interface_mapping;
1780 arglist = NULL_TREE;
1781 retargs = NULL_TREE;
1782 stringargs = NULL_TREE;
1788 if (!sym->attr.elemental)
1790 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1791 if (se->ss->useflags)
1793 gcc_assert (gfc_return_by_reference (sym)
1794 && sym->result->attr.dimension);
1795 gcc_assert (se->loop != NULL);
1797 /* Access the previously obtained result. */
1798 gfc_conv_tmp_array_ref (se);
1799 gfc_advance_se_ss_chain (se);
1803 info = &se->ss->data.info;
1808 gfc_init_interface_mapping (&mapping);
1809 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1810 && sym->ts.cl->length
1811 && sym->ts.cl->length->expr_type
1813 || sym->attr.dimension);
1814 formal = sym->formal;
1815 /* Evaluate the arguments. */
1816 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1818 if (arg->expr == NULL)
1821 if (se->ignore_optional)
1823 /* Some intrinsics have already been resolved to the correct
1827 else if (arg->label)
1829 has_alternate_specifier = 1;
1834 /* Pass a NULL pointer for an absent arg. */
1835 gfc_init_se (&parmse, NULL);
1836 parmse.expr = null_pointer_node;
1837 if (arg->missing_arg_type == BT_CHARACTER)
1838 parmse.string_length = convert (gfc_charlen_type_node,
1842 else if (se->ss && se->ss->useflags)
1844 /* An elemental function inside a scalarized loop. */
1845 gfc_init_se (&parmse, se);
1846 gfc_conv_expr_reference (&parmse, arg->expr);
1850 /* A scalar or transformational function. */
1851 gfc_init_se (&parmse, NULL);
1852 argss = gfc_walk_expr (arg->expr);
1854 if (argss == gfc_ss_terminator)
1856 gfc_conv_expr_reference (&parmse, arg->expr);
1857 if (formal && formal->sym->attr.pointer
1858 && arg->expr->expr_type != EXPR_NULL)
1860 /* Scalar pointer dummy args require an extra level of
1861 indirection. The null pointer already contains
1862 this level of indirection. */
1863 parmse.expr = build_fold_addr_expr (parmse.expr);
1868 /* If the procedure requires an explicit interface, the
1869 actual argument is passed according to the
1870 corresponding formal argument. If the corresponding
1871 formal argument is a POINTER or assumed shape, we do
1872 not use g77's calling convention, and pass the
1873 address of the array descriptor instead. Otherwise we
1874 use g77's calling convention. */
1876 f = (formal != NULL)
1877 && !formal->sym->attr.pointer
1878 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1879 f = f || !sym->attr.always_explicit;
1880 if (arg->expr->expr_type == EXPR_VARIABLE
1881 && is_aliased_array (arg->expr))
1882 /* The actual argument is a component reference to an
1883 array of derived types. In this case, the argument
1884 is converted to a temporary, which is passed and then
1885 written back after the procedure call. */
1886 gfc_conv_aliased_arg (&parmse, arg->expr, f);
1888 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1892 if (formal && need_interface_mapping)
1893 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1895 gfc_add_block_to_block (&se->pre, &parmse.pre);
1896 gfc_add_block_to_block (&se->post, &parmse.post);
1898 /* Character strings are passed as two parameters, a length and a
1900 if (parmse.string_length != NULL_TREE)
1901 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1903 arglist = gfc_chainon_list (arglist, parmse.expr);
1905 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1908 if (ts.type == BT_CHARACTER)
1910 if (sym->ts.cl->length == NULL)
1912 /* Assumed character length results are not allowed by 5.1.1.5 of the
1913 standard and are trapped in resolve.c; except in the case of SPREAD
1914 (and other intrinsics?). In this case, we take the character length
1915 of the first argument for the result. */
1916 cl.backend_decl = TREE_VALUE (stringargs);
1920 /* Calculate the length of the returned string. */
1921 gfc_init_se (&parmse, NULL);
1922 if (need_interface_mapping)
1923 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1925 gfc_conv_expr (&parmse, sym->ts.cl->length);
1926 gfc_add_block_to_block (&se->pre, &parmse.pre);
1927 gfc_add_block_to_block (&se->post, &parmse.post);
1928 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1931 /* Set up a charlen structure for it. */
1936 len = cl.backend_decl;
1939 byref = gfc_return_by_reference (sym);
1942 if (se->direct_byref)
1943 retargs = gfc_chainon_list (retargs, se->expr);
1944 else if (sym->result->attr.dimension)
1946 gcc_assert (se->loop && info);
1948 /* Set the type of the array. */
1949 tmp = gfc_typenode_for_spec (&ts);
1950 info->dimen = se->loop->dimen;
1952 /* Evaluate the bounds of the result, if known. */
1953 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1955 /* Allocate a temporary to store the result. */
1956 gfc_trans_allocate_temp_array (&se->pre, &se->post,
1957 se->loop, info, tmp, false);
1959 /* Zero the first stride to indicate a temporary. */
1960 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1961 gfc_add_modify_expr (&se->pre, tmp,
1962 convert (TREE_TYPE (tmp), integer_zero_node));
1964 /* Pass the temporary as the first argument. */
1965 tmp = info->descriptor;
1966 tmp = build_fold_addr_expr (tmp);
1967 retargs = gfc_chainon_list (retargs, tmp);
1969 else if (ts.type == BT_CHARACTER)
1971 /* Pass the string length. */
1972 type = gfc_get_character_type (ts.kind, ts.cl);
1973 type = build_pointer_type (type);
1975 /* Return an address to a char[0:len-1]* temporary for
1976 character pointers. */
1977 if (sym->attr.pointer || sym->attr.allocatable)
1979 /* Build char[0:len-1] * pstr. */
1980 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1981 build_int_cst (gfc_charlen_type_node, 1));
1982 tmp = build_range_type (gfc_array_index_type,
1983 gfc_index_zero_node, tmp);
1984 tmp = build_array_type (gfc_character1_type_node, tmp);
1985 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1987 /* Provide an address expression for the function arguments. */
1988 var = build_fold_addr_expr (var);
1991 var = gfc_conv_string_tmp (se, type, len);
1993 retargs = gfc_chainon_list (retargs, var);
1997 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1999 type = gfc_get_complex_type (ts.kind);
2000 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2001 retargs = gfc_chainon_list (retargs, var);
2004 /* Add the string length to the argument list. */
2005 if (ts.type == BT_CHARACTER)
2006 retargs = gfc_chainon_list (retargs, len);
2008 gfc_free_interface_mapping (&mapping);
2010 /* Add the return arguments. */
2011 arglist = chainon (retargs, arglist);
2013 /* Add the hidden string length parameters to the arguments. */
2014 arglist = chainon (arglist, stringargs);
2016 /* Generate the actual call. */
2017 gfc_conv_function_val (se, sym);
2018 /* If there are alternate return labels, function type should be
2019 integer. Can't modify the type in place though, since it can be shared
2020 with other functions. */
2021 if (has_alternate_specifier
2022 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2024 gcc_assert (! sym->attr.dummy);
2025 TREE_TYPE (sym->backend_decl)
2026 = build_function_type (integer_type_node,
2027 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2028 se->expr = build_fold_addr_expr (sym->backend_decl);
2031 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2032 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2033 arglist, NULL_TREE);
2035 /* If we have a pointer function, but we don't want a pointer, e.g.
2038 where f is pointer valued, we have to dereference the result. */
2039 if (!se->want_pointer && !byref && sym->attr.pointer)
2040 se->expr = build_fold_indirect_ref (se->expr);
2042 /* f2c calling conventions require a scalar default real function to
2043 return a double precision result. Convert this back to default
2044 real. We only care about the cases that can happen in Fortran 77.
2046 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2047 && sym->ts.kind == gfc_default_real_kind
2048 && !sym->attr.always_explicit)
2049 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2051 /* A pure function may still have side-effects - it may modify its
2053 TREE_SIDE_EFFECTS (se->expr) = 1;
2055 if (!sym->attr.pure)
2056 TREE_SIDE_EFFECTS (se->expr) = 1;
2061 /* Add the function call to the pre chain. There is no expression. */
2062 gfc_add_expr_to_block (&se->pre, se->expr);
2063 se->expr = NULL_TREE;
2065 if (!se->direct_byref)
2067 if (sym->attr.dimension)
2069 if (flag_bounds_check)
2071 /* Check the data pointer hasn't been modified. This would
2072 happen in a function returning a pointer. */
2073 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2074 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2076 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
2078 se->expr = info->descriptor;
2079 /* Bundle in the string length. */
2080 se->string_length = len;
2082 else if (sym->ts.type == BT_CHARACTER)
2084 /* Dereference for character pointer results. */
2085 if (sym->attr.pointer || sym->attr.allocatable)
2086 se->expr = build_fold_indirect_ref (var);
2090 se->string_length = len;
2094 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2095 se->expr = build_fold_indirect_ref (var);
2100 return has_alternate_specifier;
2104 /* Generate code to copy a string. */
2107 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
2108 tree slen, tree src)
2114 /* Deal with single character specially. */
2115 dsc = gfc_to_single_character (dlen, dest);
2116 ssc = gfc_to_single_character (slen, src);
2117 if (dsc != NULL_TREE && ssc != NULL_TREE)
2119 gfc_add_modify_expr (block, dsc, ssc);
2124 tmp = gfc_chainon_list (tmp, dlen);
2125 tmp = gfc_chainon_list (tmp, dest);
2126 tmp = gfc_chainon_list (tmp, slen);
2127 tmp = gfc_chainon_list (tmp, src);
2128 tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
2129 gfc_add_expr_to_block (block, tmp);
2133 /* Translate a statement function.
2134 The value of a statement function reference is obtained by evaluating the
2135 expression using the values of the actual arguments for the values of the
2136 corresponding dummy arguments. */
2139 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2143 gfc_formal_arglist *fargs;
2144 gfc_actual_arglist *args;
2147 gfc_saved_var *saved_vars;
2153 sym = expr->symtree->n.sym;
2154 args = expr->value.function.actual;
2155 gfc_init_se (&lse, NULL);
2156 gfc_init_se (&rse, NULL);
2159 for (fargs = sym->formal; fargs; fargs = fargs->next)
2161 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2162 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2164 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2166 /* Each dummy shall be specified, explicitly or implicitly, to be
2168 gcc_assert (fargs->sym->attr.dimension == 0);
2171 /* Create a temporary to hold the value. */
2172 type = gfc_typenode_for_spec (&fsym->ts);
2173 temp_vars[n] = gfc_create_var (type, fsym->name);
2175 if (fsym->ts.type == BT_CHARACTER)
2177 /* Copy string arguments. */
2180 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2181 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2183 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2184 tmp = gfc_build_addr_expr (build_pointer_type (type),
2187 gfc_conv_expr (&rse, args->expr);
2188 gfc_conv_string_parameter (&rse);
2189 gfc_add_block_to_block (&se->pre, &lse.pre);
2190 gfc_add_block_to_block (&se->pre, &rse.pre);
2192 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2194 gfc_add_block_to_block (&se->pre, &lse.post);
2195 gfc_add_block_to_block (&se->pre, &rse.post);
2199 /* For everything else, just evaluate the expression. */
2200 gfc_conv_expr (&lse, args->expr);
2202 gfc_add_block_to_block (&se->pre, &lse.pre);
2203 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2204 gfc_add_block_to_block (&se->pre, &lse.post);
2210 /* Use the temporary variables in place of the real ones. */
2211 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2212 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2214 gfc_conv_expr (se, sym->value);
2216 if (sym->ts.type == BT_CHARACTER)
2218 gfc_conv_const_charlen (sym->ts.cl);
2220 /* Force the expression to the correct length. */
2221 if (!INTEGER_CST_P (se->string_length)
2222 || tree_int_cst_lt (se->string_length,
2223 sym->ts.cl->backend_decl))
2225 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2226 tmp = gfc_create_var (type, sym->name);
2227 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2228 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2229 se->string_length, se->expr);
2232 se->string_length = sym->ts.cl->backend_decl;
2235 /* Restore the original variables. */
2236 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2237 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2238 gfc_free (saved_vars);
2242 /* Translate a function expression. */
2245 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2249 if (expr->value.function.isym)
2251 gfc_conv_intrinsic_function (se, expr);
2255 /* We distinguish statement functions from general functions to improve
2256 runtime performance. */
2257 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2259 gfc_conv_statement_function (se, expr);
2263 /* expr.value.function.esym is the resolved (specific) function symbol for
2264 most functions. However this isn't set for dummy procedures. */
2265 sym = expr->value.function.esym;
2267 sym = expr->symtree->n.sym;
2268 gfc_conv_function_call (se, sym, expr->value.function.actual);
2273 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2275 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2276 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2278 gfc_conv_tmp_array_ref (se);
2279 gfc_advance_se_ss_chain (se);
2283 /* Build a static initializer. EXPR is the expression for the initial value.
2284 The other parameters describe the variable of the component being
2285 initialized. EXPR may be null. */
2288 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2289 bool array, bool pointer)
2293 if (!(expr || pointer))
2298 /* Arrays need special handling. */
2300 return gfc_build_null_descriptor (type);
2302 return gfc_conv_array_initializer (type, expr);
2305 return fold_convert (type, null_pointer_node);
2311 gfc_init_se (&se, NULL);
2312 gfc_conv_structure (&se, expr, 1);
2316 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2319 gfc_init_se (&se, NULL);
2320 gfc_conv_constant (&se, expr);
2327 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2339 gfc_start_block (&block);
2341 /* Initialize the scalarizer. */
2342 gfc_init_loopinfo (&loop);
2344 gfc_init_se (&lse, NULL);
2345 gfc_init_se (&rse, NULL);
2348 rss = gfc_walk_expr (expr);
2349 if (rss == gfc_ss_terminator)
2351 /* The rhs is scalar. Add a ss for the expression. */
2352 rss = gfc_get_ss ();
2353 rss->next = gfc_ss_terminator;
2354 rss->type = GFC_SS_SCALAR;
2358 /* Create a SS for the destination. */
2359 lss = gfc_get_ss ();
2360 lss->type = GFC_SS_COMPONENT;
2362 lss->shape = gfc_get_shape (cm->as->rank);
2363 lss->next = gfc_ss_terminator;
2364 lss->data.info.dimen = cm->as->rank;
2365 lss->data.info.descriptor = dest;
2366 lss->data.info.data = gfc_conv_array_data (dest);
2367 lss->data.info.offset = gfc_conv_array_offset (dest);
2368 for (n = 0; n < cm->as->rank; n++)
2370 lss->data.info.dim[n] = n;
2371 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2372 lss->data.info.stride[n] = gfc_index_one_node;
2374 mpz_init (lss->shape[n]);
2375 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2376 cm->as->lower[n]->value.integer);
2377 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2380 /* Associate the SS with the loop. */
2381 gfc_add_ss_to_loop (&loop, lss);
2382 gfc_add_ss_to_loop (&loop, rss);
2384 /* Calculate the bounds of the scalarization. */
2385 gfc_conv_ss_startstride (&loop);
2387 /* Setup the scalarizing loops. */
2388 gfc_conv_loop_setup (&loop);
2390 /* Setup the gfc_se structures. */
2391 gfc_copy_loopinfo_to_se (&lse, &loop);
2392 gfc_copy_loopinfo_to_se (&rse, &loop);
2395 gfc_mark_ss_chain_used (rss, 1);
2397 gfc_mark_ss_chain_used (lss, 1);
2399 /* Start the scalarized loop body. */
2400 gfc_start_scalarized_body (&loop, &body);
2402 gfc_conv_tmp_array_ref (&lse);
2403 if (cm->ts.type == BT_CHARACTER)
2404 lse.string_length = cm->ts.cl->backend_decl;
2406 gfc_conv_expr (&rse, expr);
2408 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2409 gfc_add_expr_to_block (&body, tmp);
2411 gcc_assert (rse.ss == gfc_ss_terminator);
2413 /* Generate the copying loops. */
2414 gfc_trans_scalarizing_loops (&loop, &body);
2416 /* Wrap the whole thing up. */
2417 gfc_add_block_to_block (&block, &loop.pre);
2418 gfc_add_block_to_block (&block, &loop.post);
2420 for (n = 0; n < cm->as->rank; n++)
2421 mpz_clear (lss->shape[n]);
2422 gfc_free (lss->shape);
2424 gfc_cleanup_loop (&loop);
2426 return gfc_finish_block (&block);
2429 /* Assign a single component of a derived type constructor. */
2432 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2439 gfc_start_block (&block);
2442 gfc_init_se (&se, NULL);
2443 /* Pointer component. */
2446 /* Array pointer. */
2447 if (expr->expr_type == EXPR_NULL)
2448 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2451 rss = gfc_walk_expr (expr);
2452 se.direct_byref = 1;
2454 gfc_conv_expr_descriptor (&se, expr, rss);
2455 gfc_add_block_to_block (&block, &se.pre);
2456 gfc_add_block_to_block (&block, &se.post);
2461 /* Scalar pointers. */
2462 se.want_pointer = 1;
2463 gfc_conv_expr (&se, expr);
2464 gfc_add_block_to_block (&block, &se.pre);
2465 gfc_add_modify_expr (&block, dest,
2466 fold_convert (TREE_TYPE (dest), se.expr));
2467 gfc_add_block_to_block (&block, &se.post);
2470 else if (cm->dimension)
2472 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2473 gfc_add_expr_to_block (&block, tmp);
2475 else if (expr->ts.type == BT_DERIVED)
2477 /* Nested derived type. */
2478 tmp = gfc_trans_structure_assign (dest, expr);
2479 gfc_add_expr_to_block (&block, tmp);
2483 /* Scalar component. */
2486 gfc_init_se (&se, NULL);
2487 gfc_init_se (&lse, NULL);
2489 gfc_conv_expr (&se, expr);
2490 if (cm->ts.type == BT_CHARACTER)
2491 lse.string_length = cm->ts.cl->backend_decl;
2493 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2494 gfc_add_expr_to_block (&block, tmp);
2496 return gfc_finish_block (&block);
2499 /* Assign a derived type constructor to a variable. */
2502 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2510 gfc_start_block (&block);
2511 cm = expr->ts.derived->components;
2512 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2514 /* Skip absent members in default initializers. */
2518 field = cm->backend_decl;
2519 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2520 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2521 gfc_add_expr_to_block (&block, tmp);
2523 return gfc_finish_block (&block);
2526 /* Build an expression for a constructor. If init is nonzero then
2527 this is part of a static variable initializer. */
2530 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2537 VEC(constructor_elt,gc) *v = NULL;
2539 gcc_assert (se->ss == NULL);
2540 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2541 type = gfc_typenode_for_spec (&expr->ts);
2545 /* Create a temporary variable and fill it in. */
2546 se->expr = gfc_create_var (type, expr->ts.derived->name);
2547 tmp = gfc_trans_structure_assign (se->expr, expr);
2548 gfc_add_expr_to_block (&se->pre, tmp);
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 val = gfc_conv_initializer (c->expr, &cm->ts,
2560 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2562 /* Append it to the constructor list. */
2563 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2565 se->expr = build_constructor (type, v);
2569 /* Translate a substring expression. */
2572 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2578 gcc_assert (ref->type == REF_SUBSTRING);
2580 se->expr = gfc_build_string_const(expr->value.character.length,
2581 expr->value.character.string);
2582 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2583 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2585 gfc_conv_substring(se,ref,expr->ts.kind);
2589 /* Entry point for expression translation. Evaluates a scalar quantity.
2590 EXPR is the expression to be translated, and SE is the state structure if
2591 called from within the scalarized. */
2594 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2596 if (se->ss && se->ss->expr == expr
2597 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2599 /* Substitute a scalar expression evaluated outside the scalarization
2601 se->expr = se->ss->data.scalar.expr;
2602 se->string_length = se->ss->string_length;
2603 gfc_advance_se_ss_chain (se);
2607 switch (expr->expr_type)
2610 gfc_conv_expr_op (se, expr);
2614 gfc_conv_function_expr (se, expr);
2618 gfc_conv_constant (se, expr);
2622 gfc_conv_variable (se, expr);
2626 se->expr = null_pointer_node;
2629 case EXPR_SUBSTRING:
2630 gfc_conv_substring_expr (se, expr);
2633 case EXPR_STRUCTURE:
2634 gfc_conv_structure (se, expr, 0);
2638 gfc_conv_array_constructor_expr (se, expr);
2647 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2648 of an assignment. */
2650 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2652 gfc_conv_expr (se, expr);
2653 /* All numeric lvalues should have empty post chains. If not we need to
2654 figure out a way of rewriting an lvalue so that it has no post chain. */
2655 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2658 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2659 numeric expressions. Used for scalar values where inserting cleanup code
2662 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2666 gcc_assert (expr->ts.type != BT_CHARACTER);
2667 gfc_conv_expr (se, expr);
2670 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2671 gfc_add_modify_expr (&se->pre, val, se->expr);
2673 gfc_add_block_to_block (&se->pre, &se->post);
2677 /* Helper to translate and expression and convert it to a particular type. */
2679 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2681 gfc_conv_expr_val (se, expr);
2682 se->expr = convert (type, se->expr);
2686 /* Converts an expression so that it can be passed by reference. Scalar
2690 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2694 if (se->ss && se->ss->expr == expr
2695 && se->ss->type == GFC_SS_REFERENCE)
2697 se->expr = se->ss->data.scalar.expr;
2698 se->string_length = se->ss->string_length;
2699 gfc_advance_se_ss_chain (se);
2703 if (expr->ts.type == BT_CHARACTER)
2705 gfc_conv_expr (se, expr);
2706 gfc_conv_string_parameter (se);
2710 if (expr->expr_type == EXPR_VARIABLE)
2712 se->want_pointer = 1;
2713 gfc_conv_expr (se, expr);
2716 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2717 gfc_add_modify_expr (&se->pre, var, se->expr);
2718 gfc_add_block_to_block (&se->pre, &se->post);
2724 gfc_conv_expr (se, expr);
2726 /* Create a temporary var to hold the value. */
2727 if (TREE_CONSTANT (se->expr))
2729 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2730 DECL_INITIAL (var) = se->expr;
2735 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2736 gfc_add_modify_expr (&se->pre, var, se->expr);
2738 gfc_add_block_to_block (&se->pre, &se->post);
2740 /* Take the address of that value. */
2741 se->expr = build_fold_addr_expr (var);
2746 gfc_trans_pointer_assign (gfc_code * code)
2748 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2752 /* Generate code for a pointer assignment. */
2755 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2765 gfc_start_block (&block);
2767 gfc_init_se (&lse, NULL);
2769 lss = gfc_walk_expr (expr1);
2770 rss = gfc_walk_expr (expr2);
2771 if (lss == gfc_ss_terminator)
2773 /* Scalar pointers. */
2774 lse.want_pointer = 1;
2775 gfc_conv_expr (&lse, expr1);
2776 gcc_assert (rss == gfc_ss_terminator);
2777 gfc_init_se (&rse, NULL);
2778 rse.want_pointer = 1;
2779 gfc_conv_expr (&rse, expr2);
2780 gfc_add_block_to_block (&block, &lse.pre);
2781 gfc_add_block_to_block (&block, &rse.pre);
2782 gfc_add_modify_expr (&block, lse.expr,
2783 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2784 gfc_add_block_to_block (&block, &rse.post);
2785 gfc_add_block_to_block (&block, &lse.post);
2789 /* Array pointer. */
2790 gfc_conv_expr_descriptor (&lse, expr1, lss);
2791 switch (expr2->expr_type)
2794 /* Just set the data pointer to null. */
2795 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2799 /* Assign directly to the pointer's descriptor. */
2800 lse.direct_byref = 1;
2801 gfc_conv_expr_descriptor (&lse, expr2, rss);
2805 /* Assign to a temporary descriptor and then copy that
2806 temporary to the pointer. */
2808 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2811 lse.direct_byref = 1;
2812 gfc_conv_expr_descriptor (&lse, expr2, rss);
2813 gfc_add_modify_expr (&lse.pre, desc, tmp);
2816 gfc_add_block_to_block (&block, &lse.pre);
2817 gfc_add_block_to_block (&block, &lse.post);
2819 return gfc_finish_block (&block);
2823 /* Makes sure se is suitable for passing as a function string parameter. */
2824 /* TODO: Need to check all callers fo this function. It may be abused. */
2827 gfc_conv_string_parameter (gfc_se * se)
2831 if (TREE_CODE (se->expr) == STRING_CST)
2833 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2837 type = TREE_TYPE (se->expr);
2838 if (TYPE_STRING_FLAG (type))
2840 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2841 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2844 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2845 gcc_assert (se->string_length
2846 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2850 /* Generate code for assignment of scalar variables. Includes character
2854 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2858 gfc_init_block (&block);
2860 if (type == BT_CHARACTER)
2862 gcc_assert (lse->string_length != NULL_TREE
2863 && rse->string_length != NULL_TREE);
2865 gfc_conv_string_parameter (lse);
2866 gfc_conv_string_parameter (rse);
2868 gfc_add_block_to_block (&block, &lse->pre);
2869 gfc_add_block_to_block (&block, &rse->pre);
2871 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2872 rse->string_length, rse->expr);
2876 gfc_add_block_to_block (&block, &lse->pre);
2877 gfc_add_block_to_block (&block, &rse->pre);
2879 gfc_add_modify_expr (&block, lse->expr,
2880 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2883 gfc_add_block_to_block (&block, &lse->post);
2884 gfc_add_block_to_block (&block, &rse->post);
2886 return gfc_finish_block (&block);
2890 /* Try to translate array(:) = func (...), where func is a transformational
2891 array function, without using a temporary. Returns NULL is this isn't the
2895 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2900 bool seen_array_ref;
2902 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2903 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2906 /* Elemental functions don't need a temporary anyway. */
2907 if (expr2->value.function.esym != NULL
2908 && expr2->value.function.esym->attr.elemental)
2911 /* Fail if EXPR1 can't be expressed as a descriptor. */
2912 if (gfc_ref_needs_temporary_p (expr1->ref))
2915 /* Check that no LHS component references appear during an array
2916 reference. This is needed because we do not have the means to
2917 span any arbitrary stride with an array descriptor. This check
2918 is not needed for the rhs because the function result has to be
2920 seen_array_ref = false;
2921 for (ref = expr1->ref; ref; ref = ref->next)
2923 if (ref->type == REF_ARRAY)
2924 seen_array_ref= true;
2925 else if (ref->type == REF_COMPONENT && seen_array_ref)
2929 /* Check for a dependency. */
2930 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
2931 expr2->value.function.esym,
2932 expr2->value.function.actual))
2935 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2937 gcc_assert (expr2->value.function.isym
2938 || (gfc_return_by_reference (expr2->value.function.esym)
2939 && expr2->value.function.esym->result->attr.dimension));
2941 ss = gfc_walk_expr (expr1);
2942 gcc_assert (ss != gfc_ss_terminator);
2943 gfc_init_se (&se, NULL);
2944 gfc_start_block (&se.pre);
2945 se.want_pointer = 1;
2947 gfc_conv_array_parameter (&se, expr1, ss, 0);
2949 se.direct_byref = 1;
2950 se.ss = gfc_walk_expr (expr2);
2951 gcc_assert (se.ss != gfc_ss_terminator);
2952 gfc_conv_function_expr (&se, expr2);
2953 gfc_add_block_to_block (&se.pre, &se.post);
2955 return gfc_finish_block (&se.pre);
2959 /* Translate an assignment. Most of the code is concerned with
2960 setting up the scalarizer. */
2963 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2968 gfc_ss *lss_section;
2975 /* Special case a single function returning an array. */
2976 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2978 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2983 /* Assignment of the form lhs = rhs. */
2984 gfc_start_block (&block);
2986 gfc_init_se (&lse, NULL);
2987 gfc_init_se (&rse, NULL);
2990 lss = gfc_walk_expr (expr1);
2992 if (lss != gfc_ss_terminator)
2994 /* The assignment needs scalarization. */
2997 /* Find a non-scalar SS from the lhs. */
2998 while (lss_section != gfc_ss_terminator
2999 && lss_section->type != GFC_SS_SECTION)
3000 lss_section = lss_section->next;
3002 gcc_assert (lss_section != gfc_ss_terminator);
3004 /* Initialize the scalarizer. */
3005 gfc_init_loopinfo (&loop);
3008 rss = gfc_walk_expr (expr2);
3009 if (rss == gfc_ss_terminator)
3011 /* The rhs is scalar. Add a ss for the expression. */
3012 rss = gfc_get_ss ();
3013 rss->next = gfc_ss_terminator;
3014 rss->type = GFC_SS_SCALAR;
3017 /* Associate the SS with the loop. */
3018 gfc_add_ss_to_loop (&loop, lss);
3019 gfc_add_ss_to_loop (&loop, rss);
3021 /* Calculate the bounds of the scalarization. */
3022 gfc_conv_ss_startstride (&loop);
3023 /* Resolve any data dependencies in the statement. */
3024 gfc_conv_resolve_dependencies (&loop, lss, rss);
3025 /* Setup the scalarizing loops. */
3026 gfc_conv_loop_setup (&loop);
3028 /* Setup the gfc_se structures. */
3029 gfc_copy_loopinfo_to_se (&lse, &loop);
3030 gfc_copy_loopinfo_to_se (&rse, &loop);
3033 gfc_mark_ss_chain_used (rss, 1);
3034 if (loop.temp_ss == NULL)
3037 gfc_mark_ss_chain_used (lss, 1);
3041 lse.ss = loop.temp_ss;
3042 gfc_mark_ss_chain_used (lss, 3);
3043 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3046 /* Start the scalarized loop body. */
3047 gfc_start_scalarized_body (&loop, &body);
3050 gfc_init_block (&body);
3052 /* Translate the expression. */
3053 gfc_conv_expr (&rse, expr2);
3055 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3057 gfc_conv_tmp_array_ref (&lse);
3058 gfc_advance_se_ss_chain (&lse);
3061 gfc_conv_expr (&lse, expr1);
3063 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3064 gfc_add_expr_to_block (&body, tmp);
3066 if (lss == gfc_ss_terminator)
3068 /* Use the scalar assignment as is. */
3069 gfc_add_block_to_block (&block, &body);
3073 gcc_assert (lse.ss == gfc_ss_terminator
3074 && rse.ss == gfc_ss_terminator);
3076 if (loop.temp_ss != NULL)
3078 gfc_trans_scalarized_loop_boundary (&loop, &body);
3080 /* We need to copy the temporary to the actual lhs. */
3081 gfc_init_se (&lse, NULL);
3082 gfc_init_se (&rse, NULL);
3083 gfc_copy_loopinfo_to_se (&lse, &loop);
3084 gfc_copy_loopinfo_to_se (&rse, &loop);
3086 rse.ss = loop.temp_ss;
3089 gfc_conv_tmp_array_ref (&rse);
3090 gfc_advance_se_ss_chain (&rse);
3091 gfc_conv_expr (&lse, expr1);
3093 gcc_assert (lse.ss == gfc_ss_terminator
3094 && rse.ss == gfc_ss_terminator);
3096 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3097 gfc_add_expr_to_block (&body, tmp);
3099 /* Generate the copying loops. */
3100 gfc_trans_scalarizing_loops (&loop, &body);
3102 /* Wrap the whole thing up. */
3103 gfc_add_block_to_block (&block, &loop.pre);
3104 gfc_add_block_to_block (&block, &loop.post);
3106 gfc_cleanup_loop (&loop);
3109 return gfc_finish_block (&block);
3113 gfc_trans_assign (gfc_code * code)
3115 return gfc_trans_assignment (code->expr, code->expr2);