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 case INTRINSIC_PARENTHESES:
929 gfc_conv_expr (se, expr->value.op.op1);
932 case INTRINSIC_UMINUS:
933 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
937 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
944 case INTRINSIC_MINUS:
948 case INTRINSIC_TIMES:
952 case INTRINSIC_DIVIDE:
953 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
954 an integer, we must round towards zero, so we use a
956 if (expr->ts.type == BT_INTEGER)
957 code = TRUNC_DIV_EXPR;
962 case INTRINSIC_POWER:
963 gfc_conv_power_op (se, expr);
966 case INTRINSIC_CONCAT:
967 gfc_conv_concat_op (se, expr);
971 code = TRUTH_ANDIF_EXPR;
976 code = TRUTH_ORIF_EXPR;
980 /* EQV and NEQV only work on logicals, but since we represent them
981 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1020 case INTRINSIC_USER:
1021 case INTRINSIC_ASSIGN:
1022 /* These should be converted into function calls by the frontend. */
1026 fatal_error ("Unknown intrinsic op");
1030 /* The only exception to this is **, which is handled separately anyway. */
1031 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1033 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1037 gfc_init_se (&lse, se);
1038 gfc_conv_expr (&lse, expr->value.op.op1);
1039 gfc_add_block_to_block (&se->pre, &lse.pre);
1042 gfc_init_se (&rse, se);
1043 gfc_conv_expr (&rse, expr->value.op.op2);
1044 gfc_add_block_to_block (&se->pre, &rse.pre);
1048 gfc_conv_string_parameter (&lse);
1049 gfc_conv_string_parameter (&rse);
1051 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1052 rse.string_length, rse.expr);
1053 rse.expr = integer_zero_node;
1054 gfc_add_block_to_block (&lse.post, &rse.post);
1057 type = gfc_typenode_for_spec (&expr->ts);
1061 /* The result of logical ops is always boolean_type_node. */
1062 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1063 se->expr = convert (type, tmp);
1066 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1068 /* Add the post blocks. */
1069 gfc_add_block_to_block (&se->post, &rse.post);
1070 gfc_add_block_to_block (&se->post, &lse.post);
1073 /* If a string's length is one, we convert it to a single character. */
1076 gfc_to_single_character (tree len, tree str)
1078 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1080 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1081 && TREE_INT_CST_HIGH (len) == 0)
1083 str = fold_convert (pchar_type_node, str);
1084 return build_fold_indirect_ref (str);
1090 /* Compare two strings. If they are all single characters, the result is the
1091 subtraction of them. Otherwise, we build a library call. */
1094 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1101 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1102 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1104 type = gfc_get_int_type (gfc_default_integer_kind);
1106 sc1 = gfc_to_single_character (len1, str1);
1107 sc2 = gfc_to_single_character (len2, str2);
1109 /* Deal with single character specially. */
1110 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1112 sc1 = fold_convert (type, sc1);
1113 sc2 = fold_convert (type, sc2);
1114 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1119 tmp = gfc_chainon_list (tmp, len1);
1120 tmp = gfc_chainon_list (tmp, str1);
1121 tmp = gfc_chainon_list (tmp, len2);
1122 tmp = gfc_chainon_list (tmp, str2);
1124 /* Build a call for the comparison. */
1125 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1132 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1136 if (sym->attr.dummy)
1138 tmp = gfc_get_symbol_decl (sym);
1139 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1140 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1144 if (!sym->backend_decl)
1145 sym->backend_decl = gfc_get_extern_function_decl (sym);
1147 tmp = sym->backend_decl;
1148 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1150 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1151 tmp = build_fold_addr_expr (tmp);
1158 /* Initialize MAPPING. */
1161 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1163 mapping->syms = NULL;
1164 mapping->charlens = NULL;
1168 /* Free all memory held by MAPPING (but not MAPPING itself). */
1171 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1173 gfc_interface_sym_mapping *sym;
1174 gfc_interface_sym_mapping *nextsym;
1176 gfc_charlen *nextcl;
1178 for (sym = mapping->syms; sym; sym = nextsym)
1180 nextsym = sym->next;
1181 gfc_free_symbol (sym->new->n.sym);
1182 gfc_free (sym->new);
1185 for (cl = mapping->charlens; cl; cl = nextcl)
1188 gfc_free_expr (cl->length);
1194 /* Return a copy of gfc_charlen CL. Add the returned structure to
1195 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1197 static gfc_charlen *
1198 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1203 new = gfc_get_charlen ();
1204 new->next = mapping->charlens;
1205 new->length = gfc_copy_expr (cl->length);
1207 mapping->charlens = new;
1212 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1213 array variable that can be used as the actual argument for dummy
1214 argument SYM. Add any initialization code to BLOCK. PACKED is as
1215 for gfc_get_nodesc_array_type and DATA points to the first element
1216 in the passed array. */
1219 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1220 int packed, tree data)
1225 type = gfc_typenode_for_spec (&sym->ts);
1226 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1228 var = gfc_create_var (type, "ifm");
1229 gfc_add_modify_expr (block, var, fold_convert (type, data));
1235 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1236 and offset of descriptorless array type TYPE given that it has the same
1237 size as DESC. Add any set-up code to BLOCK. */
1240 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1247 offset = gfc_index_zero_node;
1248 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1250 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1251 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1253 dim = gfc_rank_cst[n];
1254 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1255 gfc_conv_descriptor_ubound (desc, dim),
1256 gfc_conv_descriptor_lbound (desc, dim));
1257 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1258 GFC_TYPE_ARRAY_LBOUND (type, n),
1260 tmp = gfc_evaluate_now (tmp, block);
1261 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1263 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1264 GFC_TYPE_ARRAY_LBOUND (type, n),
1265 GFC_TYPE_ARRAY_STRIDE (type, n));
1266 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1268 offset = gfc_evaluate_now (offset, block);
1269 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1273 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1274 in SE. The caller may still use se->expr and se->string_length after
1275 calling this function. */
1278 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1279 gfc_symbol * sym, gfc_se * se)
1281 gfc_interface_sym_mapping *sm;
1285 gfc_symbol *new_sym;
1287 gfc_symtree *new_symtree;
1289 /* Create a new symbol to represent the actual argument. */
1290 new_sym = gfc_new_symbol (sym->name, NULL);
1291 new_sym->ts = sym->ts;
1292 new_sym->attr.referenced = 1;
1293 new_sym->attr.dimension = sym->attr.dimension;
1294 new_sym->attr.pointer = sym->attr.pointer;
1295 new_sym->attr.flavor = sym->attr.flavor;
1297 /* Create a fake symtree for it. */
1299 new_symtree = gfc_new_symtree (&root, sym->name);
1300 new_symtree->n.sym = new_sym;
1301 gcc_assert (new_symtree == root);
1303 /* Create a dummy->actual mapping. */
1304 sm = gfc_getmem (sizeof (*sm));
1305 sm->next = mapping->syms;
1307 sm->new = new_symtree;
1310 /* Stabilize the argument's value. */
1311 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1313 if (sym->ts.type == BT_CHARACTER)
1315 /* Create a copy of the dummy argument's length. */
1316 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1318 /* If the length is specified as "*", record the length that
1319 the caller is passing. We should use the callee's length
1320 in all other cases. */
1321 if (!new_sym->ts.cl->length)
1323 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1324 new_sym->ts.cl->backend_decl = se->string_length;
1328 /* Use the passed value as-is if the argument is a function. */
1329 if (sym->attr.flavor == FL_PROCEDURE)
1332 /* If the argument is either a string or a pointer to a string,
1333 convert it to a boundless character type. */
1334 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1336 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1337 tmp = build_pointer_type (tmp);
1338 if (sym->attr.pointer)
1339 tmp = build_pointer_type (tmp);
1341 value = fold_convert (tmp, se->expr);
1342 if (sym->attr.pointer)
1343 value = build_fold_indirect_ref (value);
1346 /* If the argument is a scalar or a pointer to an array, dereference it. */
1347 else if (!sym->attr.dimension || sym->attr.pointer)
1348 value = build_fold_indirect_ref (se->expr);
1350 /* For character(*), use the actual argument's descriptor. */
1351 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1352 value = build_fold_indirect_ref (se->expr);
1354 /* If the argument is an array descriptor, use it to determine
1355 information about the actual argument's shape. */
1356 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1357 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1359 /* Get the actual argument's descriptor. */
1360 desc = build_fold_indirect_ref (se->expr);
1362 /* Create the replacement variable. */
1363 tmp = gfc_conv_descriptor_data_get (desc);
1364 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1366 /* Use DESC to work out the upper bounds, strides and offset. */
1367 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1370 /* Otherwise we have a packed array. */
1371 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1373 new_sym->backend_decl = value;
1377 /* Called once all dummy argument mappings have been added to MAPPING,
1378 but before the mapping is used to evaluate expressions. Pre-evaluate
1379 the length of each argument, adding any initialization code to PRE and
1380 any finalization code to POST. */
1383 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1384 stmtblock_t * pre, stmtblock_t * post)
1386 gfc_interface_sym_mapping *sym;
1390 for (sym = mapping->syms; sym; sym = sym->next)
1391 if (sym->new->n.sym->ts.type == BT_CHARACTER
1392 && !sym->new->n.sym->ts.cl->backend_decl)
1394 expr = sym->new->n.sym->ts.cl->length;
1395 gfc_apply_interface_mapping_to_expr (mapping, expr);
1396 gfc_init_se (&se, NULL);
1397 gfc_conv_expr (&se, expr);
1399 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1400 gfc_add_block_to_block (pre, &se.pre);
1401 gfc_add_block_to_block (post, &se.post);
1403 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1408 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1412 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1413 gfc_constructor * c)
1415 for (; c; c = c->next)
1417 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1420 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1421 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1422 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1428 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1432 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1437 for (; ref; ref = ref->next)
1441 for (n = 0; n < ref->u.ar.dimen; n++)
1443 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1444 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1445 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1447 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1454 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1455 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1461 /* EXPR is a copy of an expression that appeared in the interface
1462 associated with MAPPING. Walk it recursively looking for references to
1463 dummy arguments that MAPPING maps to actual arguments. Replace each such
1464 reference with a reference to the associated actual argument. */
1467 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1470 gfc_interface_sym_mapping *sym;
1471 gfc_actual_arglist *actual;
1476 /* Copying an expression does not copy its length, so do that here. */
1477 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1479 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1480 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1483 /* Apply the mapping to any references. */
1484 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1486 /* ...and to the expression's symbol, if it has one. */
1488 for (sym = mapping->syms; sym; sym = sym->next)
1489 if (sym->old == expr->symtree->n.sym)
1490 expr->symtree = sym->new;
1492 /* ...and to subexpressions in expr->value. */
1493 switch (expr->expr_type)
1498 case EXPR_SUBSTRING:
1502 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1503 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1507 for (sym = mapping->syms; sym; sym = sym->next)
1508 if (sym->old == expr->value.function.esym)
1509 expr->value.function.esym = sym->new->n.sym;
1511 for (actual = expr->value.function.actual; actual; actual = actual->next)
1512 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1516 case EXPR_STRUCTURE:
1517 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1523 /* Evaluate interface expression EXPR using MAPPING. Store the result
1527 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1528 gfc_se * se, gfc_expr * expr)
1530 expr = gfc_copy_expr (expr);
1531 gfc_apply_interface_mapping_to_expr (mapping, expr);
1532 gfc_conv_expr (se, expr);
1533 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1534 gfc_free_expr (expr);
1537 /* Returns a reference to a temporary array into which a component of
1538 an actual argument derived type array is copied and then returned
1539 after the function call.
1540 TODO Get rid of this kludge, when array descriptors are capable of
1541 handling aliased arrays. */
1544 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
1560 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1562 gfc_init_se (&lse, NULL);
1563 gfc_init_se (&rse, NULL);
1565 /* Walk the argument expression. */
1566 rss = gfc_walk_expr (expr);
1568 gcc_assert (rss != gfc_ss_terminator);
1570 /* Initialize the scalarizer. */
1571 gfc_init_loopinfo (&loop);
1572 gfc_add_ss_to_loop (&loop, rss);
1574 /* Calculate the bounds of the scalarization. */
1575 gfc_conv_ss_startstride (&loop);
1577 /* Build an ss for the temporary. */
1578 base_type = gfc_typenode_for_spec (&expr->ts);
1579 if (GFC_ARRAY_TYPE_P (base_type)
1580 || GFC_DESCRIPTOR_TYPE_P (base_type))
1581 base_type = gfc_get_element_type (base_type);
1583 loop.temp_ss = gfc_get_ss ();;
1584 loop.temp_ss->type = GFC_SS_TEMP;
1585 loop.temp_ss->data.temp.type = base_type;
1587 if (expr->ts.type == BT_CHARACTER)
1588 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1590 loop.temp_ss->data.temp.dimen = loop.dimen;
1591 loop.temp_ss->next = gfc_ss_terminator;
1593 /* Associate the SS with the loop. */
1594 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1596 /* Setup the scalarizing loops. */
1597 gfc_conv_loop_setup (&loop);
1599 /* Pass the temporary descriptor back to the caller. */
1600 info = &loop.temp_ss->data.info;
1601 parmse->expr = info->descriptor;
1603 /* Setup the gfc_se structures. */
1604 gfc_copy_loopinfo_to_se (&lse, &loop);
1605 gfc_copy_loopinfo_to_se (&rse, &loop);
1608 lse.ss = loop.temp_ss;
1609 gfc_mark_ss_chain_used (rss, 1);
1610 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1612 /* Start the scalarized loop body. */
1613 gfc_start_scalarized_body (&loop, &body);
1615 /* Translate the expression. */
1616 gfc_conv_expr (&rse, expr);
1618 gfc_conv_tmp_array_ref (&lse);
1619 gfc_advance_se_ss_chain (&lse);
1621 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1622 gfc_add_expr_to_block (&body, tmp);
1624 gcc_assert (rse.ss == gfc_ss_terminator);
1626 gfc_trans_scalarizing_loops (&loop, &body);
1628 /* Add the post block after the second loop, so that any
1629 freeing of allocated memory is done at the right time. */
1630 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1632 /**********Copy the temporary back again.*********/
1634 gfc_init_se (&lse, NULL);
1635 gfc_init_se (&rse, NULL);
1637 /* Walk the argument expression. */
1638 lss = gfc_walk_expr (expr);
1639 rse.ss = loop.temp_ss;
1642 /* Initialize the scalarizer. */
1643 gfc_init_loopinfo (&loop2);
1644 gfc_add_ss_to_loop (&loop2, lss);
1646 /* Calculate the bounds of the scalarization. */
1647 gfc_conv_ss_startstride (&loop2);
1649 /* Setup the scalarizing loops. */
1650 gfc_conv_loop_setup (&loop2);
1652 gfc_copy_loopinfo_to_se (&lse, &loop2);
1653 gfc_copy_loopinfo_to_se (&rse, &loop2);
1655 gfc_mark_ss_chain_used (lss, 1);
1656 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1658 /* Declare the variable to hold the temporary offset and start the
1659 scalarized loop body. */
1660 offset = gfc_create_var (gfc_array_index_type, NULL);
1661 gfc_start_scalarized_body (&loop2, &body);
1663 /* Build the offsets for the temporary from the loop variables. The
1664 temporary array has lbounds of zero and strides of one in all
1665 dimensions, so this is very simple. The offset is only computed
1666 outside the innermost loop, so the overall transfer could be
1667 optimised further. */
1668 info = &rse.ss->data.info;
1670 tmp_index = gfc_index_zero_node;
1671 for (n = info->dimen - 1; n > 0; n--)
1674 tmp = rse.loop->loopvar[n];
1675 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1676 tmp, rse.loop->from[n]);
1677 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1680 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1681 rse.loop->to[n-1], rse.loop->from[n-1]);
1682 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1683 tmp_str, gfc_index_one_node);
1685 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1689 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1690 tmp_index, rse.loop->from[0]);
1691 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1693 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1694 rse.loop->loopvar[0], offset);
1696 /* Now use the offset for the reference. */
1697 tmp = build_fold_indirect_ref (info->data);
1698 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1700 if (expr->ts.type == BT_CHARACTER)
1701 rse.string_length = expr->ts.cl->backend_decl;
1703 gfc_conv_expr (&lse, expr);
1705 gcc_assert (lse.ss == gfc_ss_terminator);
1707 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1708 gfc_add_expr_to_block (&body, tmp);
1710 /* Generate the copying loops. */
1711 gfc_trans_scalarizing_loops (&loop2, &body);
1713 /* Wrap the whole thing up by adding the second loop to the post-block
1714 and following it by the post-block of the fist loop. In this way,
1715 if the temporary needs freeing, it is done after use! */
1716 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1717 gfc_add_block_to_block (&parmse->post, &loop2.post);
1719 gfc_add_block_to_block (&parmse->post, &loop.post);
1721 gfc_cleanup_loop (&loop);
1722 gfc_cleanup_loop (&loop2);
1724 /* Pass the string length to the argument expression. */
1725 if (expr->ts.type == BT_CHARACTER)
1726 parmse->string_length = expr->ts.cl->backend_decl;
1728 /* We want either the address for the data or the address of the descriptor,
1729 depending on the mode of passing array arguments. */
1731 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1733 parmse->expr = build_fold_addr_expr (parmse->expr);
1738 /* Is true if the last array reference is followed by a component reference. */
1741 is_aliased_array (gfc_expr * e)
1747 for (ref = e->ref; ref; ref = ref->next)
1749 if (ref->type == REF_ARRAY)
1752 if (ref->next == NULL && ref->type == REF_COMPONENT)
1758 /* Generate code for a procedure call. Note can return se->post != NULL.
1759 If se->direct_byref is set then se->expr contains the return parameter.
1760 Return nonzero, if the call has alternate specifiers. */
1763 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1764 gfc_actual_arglist * arg)
1766 gfc_interface_mapping mapping;
1779 gfc_formal_arglist *formal;
1780 int has_alternate_specifier = 0;
1781 bool need_interface_mapping;
1785 arglist = NULL_TREE;
1786 retargs = NULL_TREE;
1787 stringargs = NULL_TREE;
1793 if (!sym->attr.elemental)
1795 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1796 if (se->ss->useflags)
1798 gcc_assert (gfc_return_by_reference (sym)
1799 && sym->result->attr.dimension);
1800 gcc_assert (se->loop != NULL);
1802 /* Access the previously obtained result. */
1803 gfc_conv_tmp_array_ref (se);
1804 gfc_advance_se_ss_chain (se);
1808 info = &se->ss->data.info;
1813 gfc_init_interface_mapping (&mapping);
1814 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1815 && sym->ts.cl->length
1816 && sym->ts.cl->length->expr_type
1818 || sym->attr.dimension);
1819 formal = sym->formal;
1820 /* Evaluate the arguments. */
1821 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1823 if (arg->expr == NULL)
1826 if (se->ignore_optional)
1828 /* Some intrinsics have already been resolved to the correct
1832 else if (arg->label)
1834 has_alternate_specifier = 1;
1839 /* Pass a NULL pointer for an absent arg. */
1840 gfc_init_se (&parmse, NULL);
1841 parmse.expr = null_pointer_node;
1842 if (arg->missing_arg_type == BT_CHARACTER)
1843 parmse.string_length = convert (gfc_charlen_type_node,
1847 else if (se->ss && se->ss->useflags)
1849 /* An elemental function inside a scalarized loop. */
1850 gfc_init_se (&parmse, se);
1851 gfc_conv_expr_reference (&parmse, arg->expr);
1855 /* A scalar or transformational function. */
1856 gfc_init_se (&parmse, NULL);
1857 argss = gfc_walk_expr (arg->expr);
1859 if (argss == gfc_ss_terminator)
1861 gfc_conv_expr_reference (&parmse, arg->expr);
1862 if (formal && formal->sym->attr.pointer
1863 && arg->expr->expr_type != EXPR_NULL)
1865 /* Scalar pointer dummy args require an extra level of
1866 indirection. The null pointer already contains
1867 this level of indirection. */
1868 parmse.expr = build_fold_addr_expr (parmse.expr);
1873 /* If the procedure requires an explicit interface, the
1874 actual argument is passed according to the
1875 corresponding formal argument. If the corresponding
1876 formal argument is a POINTER or assumed shape, we do
1877 not use g77's calling convention, and pass the
1878 address of the array descriptor instead. Otherwise we
1879 use g77's calling convention. */
1881 f = (formal != NULL)
1882 && !formal->sym->attr.pointer
1883 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1884 f = f || !sym->attr.always_explicit;
1885 if (arg->expr->expr_type == EXPR_VARIABLE
1886 && is_aliased_array (arg->expr))
1887 /* The actual argument is a component reference to an
1888 array of derived types. In this case, the argument
1889 is converted to a temporary, which is passed and then
1890 written back after the procedure call. */
1891 gfc_conv_aliased_arg (&parmse, arg->expr, f);
1893 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1897 if (formal && need_interface_mapping)
1898 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1900 gfc_add_block_to_block (&se->pre, &parmse.pre);
1901 gfc_add_block_to_block (&se->post, &parmse.post);
1903 /* Character strings are passed as two parameters, a length and a
1905 if (parmse.string_length != NULL_TREE)
1906 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1908 arglist = gfc_chainon_list (arglist, parmse.expr);
1910 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1913 if (ts.type == BT_CHARACTER)
1915 if (sym->ts.cl->length == NULL)
1917 /* Assumed character length results are not allowed by 5.1.1.5 of the
1918 standard and are trapped in resolve.c; except in the case of SPREAD
1919 (and other intrinsics?). In this case, we take the character length
1920 of the first argument for the result. */
1921 cl.backend_decl = TREE_VALUE (stringargs);
1925 /* Calculate the length of the returned string. */
1926 gfc_init_se (&parmse, NULL);
1927 if (need_interface_mapping)
1928 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1930 gfc_conv_expr (&parmse, sym->ts.cl->length);
1931 gfc_add_block_to_block (&se->pre, &parmse.pre);
1932 gfc_add_block_to_block (&se->post, &parmse.post);
1933 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1936 /* Set up a charlen structure for it. */
1941 len = cl.backend_decl;
1944 byref = gfc_return_by_reference (sym);
1947 if (se->direct_byref)
1948 retargs = gfc_chainon_list (retargs, se->expr);
1949 else if (sym->result->attr.dimension)
1951 gcc_assert (se->loop && info);
1953 /* Set the type of the array. */
1954 tmp = gfc_typenode_for_spec (&ts);
1955 info->dimen = se->loop->dimen;
1957 /* Evaluate the bounds of the result, if known. */
1958 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1960 /* Allocate a temporary to store the result. In case the function
1961 returns a pointer, the temporary will be a shallow copy and
1962 mustn't be deallocated. */
1963 gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info,
1964 tmp, false, !sym->attr.pointer);
1966 /* Zero the first stride to indicate a temporary. */
1967 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1968 gfc_add_modify_expr (&se->pre, tmp,
1969 convert (TREE_TYPE (tmp), integer_zero_node));
1971 /* Pass the temporary as the first argument. */
1972 tmp = info->descriptor;
1973 tmp = build_fold_addr_expr (tmp);
1974 retargs = gfc_chainon_list (retargs, tmp);
1976 else if (ts.type == BT_CHARACTER)
1978 /* Pass the string length. */
1979 type = gfc_get_character_type (ts.kind, ts.cl);
1980 type = build_pointer_type (type);
1982 /* Return an address to a char[0:len-1]* temporary for
1983 character pointers. */
1984 if (sym->attr.pointer || sym->attr.allocatable)
1986 /* Build char[0:len-1] * pstr. */
1987 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1988 build_int_cst (gfc_charlen_type_node, 1));
1989 tmp = build_range_type (gfc_array_index_type,
1990 gfc_index_zero_node, tmp);
1991 tmp = build_array_type (gfc_character1_type_node, tmp);
1992 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1994 /* Provide an address expression for the function arguments. */
1995 var = build_fold_addr_expr (var);
1998 var = gfc_conv_string_tmp (se, type, len);
2000 retargs = gfc_chainon_list (retargs, var);
2004 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2006 type = gfc_get_complex_type (ts.kind);
2007 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2008 retargs = gfc_chainon_list (retargs, var);
2011 /* Add the string length to the argument list. */
2012 if (ts.type == BT_CHARACTER)
2013 retargs = gfc_chainon_list (retargs, len);
2015 gfc_free_interface_mapping (&mapping);
2017 /* Add the return arguments. */
2018 arglist = chainon (retargs, arglist);
2020 /* Add the hidden string length parameters to the arguments. */
2021 arglist = chainon (arglist, stringargs);
2023 /* Generate the actual call. */
2024 gfc_conv_function_val (se, sym);
2025 /* If there are alternate return labels, function type should be
2026 integer. Can't modify the type in place though, since it can be shared
2027 with other functions. */
2028 if (has_alternate_specifier
2029 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2031 gcc_assert (! sym->attr.dummy);
2032 TREE_TYPE (sym->backend_decl)
2033 = build_function_type (integer_type_node,
2034 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2035 se->expr = build_fold_addr_expr (sym->backend_decl);
2038 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2039 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2040 arglist, NULL_TREE);
2042 /* If we have a pointer function, but we don't want a pointer, e.g.
2045 where f is pointer valued, we have to dereference the result. */
2046 if (!se->want_pointer && !byref && sym->attr.pointer)
2047 se->expr = build_fold_indirect_ref (se->expr);
2049 /* f2c calling conventions require a scalar default real function to
2050 return a double precision result. Convert this back to default
2051 real. We only care about the cases that can happen in Fortran 77.
2053 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2054 && sym->ts.kind == gfc_default_real_kind
2055 && !sym->attr.always_explicit)
2056 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2058 /* A pure function may still have side-effects - it may modify its
2060 TREE_SIDE_EFFECTS (se->expr) = 1;
2062 if (!sym->attr.pure)
2063 TREE_SIDE_EFFECTS (se->expr) = 1;
2068 /* Add the function call to the pre chain. There is no expression. */
2069 gfc_add_expr_to_block (&se->pre, se->expr);
2070 se->expr = NULL_TREE;
2072 if (!se->direct_byref)
2074 if (sym->attr.dimension)
2076 if (flag_bounds_check)
2078 /* Check the data pointer hasn't been modified. This would
2079 happen in a function returning a pointer. */
2080 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2081 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2083 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
2085 se->expr = info->descriptor;
2086 /* Bundle in the string length. */
2087 se->string_length = len;
2089 else if (sym->ts.type == BT_CHARACTER)
2091 /* Dereference for character pointer results. */
2092 if (sym->attr.pointer || sym->attr.allocatable)
2093 se->expr = build_fold_indirect_ref (var);
2097 se->string_length = len;
2101 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2102 se->expr = build_fold_indirect_ref (var);
2107 return has_alternate_specifier;
2111 /* Generate code to copy a string. */
2114 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
2115 tree slen, tree src)
2121 /* Deal with single character specially. */
2122 dsc = gfc_to_single_character (dlen, dest);
2123 ssc = gfc_to_single_character (slen, src);
2124 if (dsc != NULL_TREE && ssc != NULL_TREE)
2126 gfc_add_modify_expr (block, dsc, ssc);
2131 tmp = gfc_chainon_list (tmp, dlen);
2132 tmp = gfc_chainon_list (tmp, dest);
2133 tmp = gfc_chainon_list (tmp, slen);
2134 tmp = gfc_chainon_list (tmp, src);
2135 tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
2136 gfc_add_expr_to_block (block, tmp);
2140 /* Translate a statement function.
2141 The value of a statement function reference is obtained by evaluating the
2142 expression using the values of the actual arguments for the values of the
2143 corresponding dummy arguments. */
2146 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2150 gfc_formal_arglist *fargs;
2151 gfc_actual_arglist *args;
2154 gfc_saved_var *saved_vars;
2160 sym = expr->symtree->n.sym;
2161 args = expr->value.function.actual;
2162 gfc_init_se (&lse, NULL);
2163 gfc_init_se (&rse, NULL);
2166 for (fargs = sym->formal; fargs; fargs = fargs->next)
2168 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2169 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2171 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2173 /* Each dummy shall be specified, explicitly or implicitly, to be
2175 gcc_assert (fargs->sym->attr.dimension == 0);
2178 /* Create a temporary to hold the value. */
2179 type = gfc_typenode_for_spec (&fsym->ts);
2180 temp_vars[n] = gfc_create_var (type, fsym->name);
2182 if (fsym->ts.type == BT_CHARACTER)
2184 /* Copy string arguments. */
2187 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2188 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2190 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2191 tmp = gfc_build_addr_expr (build_pointer_type (type),
2194 gfc_conv_expr (&rse, args->expr);
2195 gfc_conv_string_parameter (&rse);
2196 gfc_add_block_to_block (&se->pre, &lse.pre);
2197 gfc_add_block_to_block (&se->pre, &rse.pre);
2199 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2201 gfc_add_block_to_block (&se->pre, &lse.post);
2202 gfc_add_block_to_block (&se->pre, &rse.post);
2206 /* For everything else, just evaluate the expression. */
2207 gfc_conv_expr (&lse, args->expr);
2209 gfc_add_block_to_block (&se->pre, &lse.pre);
2210 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2211 gfc_add_block_to_block (&se->pre, &lse.post);
2217 /* Use the temporary variables in place of the real ones. */
2218 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2219 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2221 gfc_conv_expr (se, sym->value);
2223 if (sym->ts.type == BT_CHARACTER)
2225 gfc_conv_const_charlen (sym->ts.cl);
2227 /* Force the expression to the correct length. */
2228 if (!INTEGER_CST_P (se->string_length)
2229 || tree_int_cst_lt (se->string_length,
2230 sym->ts.cl->backend_decl))
2232 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2233 tmp = gfc_create_var (type, sym->name);
2234 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2235 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2236 se->string_length, se->expr);
2239 se->string_length = sym->ts.cl->backend_decl;
2242 /* Restore the original variables. */
2243 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2244 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2245 gfc_free (saved_vars);
2249 /* Translate a function expression. */
2252 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2256 if (expr->value.function.isym)
2258 gfc_conv_intrinsic_function (se, expr);
2262 /* We distinguish statement functions from general functions to improve
2263 runtime performance. */
2264 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2266 gfc_conv_statement_function (se, expr);
2270 /* expr.value.function.esym is the resolved (specific) function symbol for
2271 most functions. However this isn't set for dummy procedures. */
2272 sym = expr->value.function.esym;
2274 sym = expr->symtree->n.sym;
2275 gfc_conv_function_call (se, sym, expr->value.function.actual);
2280 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2282 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2283 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2285 gfc_conv_tmp_array_ref (se);
2286 gfc_advance_se_ss_chain (se);
2290 /* Build a static initializer. EXPR is the expression for the initial value.
2291 The other parameters describe the variable of the component being
2292 initialized. EXPR may be null. */
2295 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2296 bool array, bool pointer)
2300 if (!(expr || pointer))
2305 /* Arrays need special handling. */
2307 return gfc_build_null_descriptor (type);
2309 return gfc_conv_array_initializer (type, expr);
2312 return fold_convert (type, null_pointer_node);
2318 gfc_init_se (&se, NULL);
2319 gfc_conv_structure (&se, expr, 1);
2323 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2326 gfc_init_se (&se, NULL);
2327 gfc_conv_constant (&se, expr);
2334 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2346 gfc_start_block (&block);
2348 /* Initialize the scalarizer. */
2349 gfc_init_loopinfo (&loop);
2351 gfc_init_se (&lse, NULL);
2352 gfc_init_se (&rse, NULL);
2355 rss = gfc_walk_expr (expr);
2356 if (rss == gfc_ss_terminator)
2358 /* The rhs is scalar. Add a ss for the expression. */
2359 rss = gfc_get_ss ();
2360 rss->next = gfc_ss_terminator;
2361 rss->type = GFC_SS_SCALAR;
2365 /* Create a SS for the destination. */
2366 lss = gfc_get_ss ();
2367 lss->type = GFC_SS_COMPONENT;
2369 lss->shape = gfc_get_shape (cm->as->rank);
2370 lss->next = gfc_ss_terminator;
2371 lss->data.info.dimen = cm->as->rank;
2372 lss->data.info.descriptor = dest;
2373 lss->data.info.data = gfc_conv_array_data (dest);
2374 lss->data.info.offset = gfc_conv_array_offset (dest);
2375 for (n = 0; n < cm->as->rank; n++)
2377 lss->data.info.dim[n] = n;
2378 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2379 lss->data.info.stride[n] = gfc_index_one_node;
2381 mpz_init (lss->shape[n]);
2382 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2383 cm->as->lower[n]->value.integer);
2384 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2387 /* Associate the SS with the loop. */
2388 gfc_add_ss_to_loop (&loop, lss);
2389 gfc_add_ss_to_loop (&loop, rss);
2391 /* Calculate the bounds of the scalarization. */
2392 gfc_conv_ss_startstride (&loop);
2394 /* Setup the scalarizing loops. */
2395 gfc_conv_loop_setup (&loop);
2397 /* Setup the gfc_se structures. */
2398 gfc_copy_loopinfo_to_se (&lse, &loop);
2399 gfc_copy_loopinfo_to_se (&rse, &loop);
2402 gfc_mark_ss_chain_used (rss, 1);
2404 gfc_mark_ss_chain_used (lss, 1);
2406 /* Start the scalarized loop body. */
2407 gfc_start_scalarized_body (&loop, &body);
2409 gfc_conv_tmp_array_ref (&lse);
2410 if (cm->ts.type == BT_CHARACTER)
2411 lse.string_length = cm->ts.cl->backend_decl;
2413 gfc_conv_expr (&rse, expr);
2415 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2416 gfc_add_expr_to_block (&body, tmp);
2418 gcc_assert (rse.ss == gfc_ss_terminator);
2420 /* Generate the copying loops. */
2421 gfc_trans_scalarizing_loops (&loop, &body);
2423 /* Wrap the whole thing up. */
2424 gfc_add_block_to_block (&block, &loop.pre);
2425 gfc_add_block_to_block (&block, &loop.post);
2427 for (n = 0; n < cm->as->rank; n++)
2428 mpz_clear (lss->shape[n]);
2429 gfc_free (lss->shape);
2431 gfc_cleanup_loop (&loop);
2433 return gfc_finish_block (&block);
2436 /* Assign a single component of a derived type constructor. */
2439 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2446 gfc_start_block (&block);
2449 gfc_init_se (&se, NULL);
2450 /* Pointer component. */
2453 /* Array pointer. */
2454 if (expr->expr_type == EXPR_NULL)
2455 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2458 rss = gfc_walk_expr (expr);
2459 se.direct_byref = 1;
2461 gfc_conv_expr_descriptor (&se, expr, rss);
2462 gfc_add_block_to_block (&block, &se.pre);
2463 gfc_add_block_to_block (&block, &se.post);
2468 /* Scalar pointers. */
2469 se.want_pointer = 1;
2470 gfc_conv_expr (&se, expr);
2471 gfc_add_block_to_block (&block, &se.pre);
2472 gfc_add_modify_expr (&block, dest,
2473 fold_convert (TREE_TYPE (dest), se.expr));
2474 gfc_add_block_to_block (&block, &se.post);
2477 else if (cm->dimension)
2479 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2480 gfc_add_expr_to_block (&block, tmp);
2482 else if (expr->ts.type == BT_DERIVED)
2484 /* Nested derived type. */
2485 tmp = gfc_trans_structure_assign (dest, expr);
2486 gfc_add_expr_to_block (&block, tmp);
2490 /* Scalar component. */
2493 gfc_init_se (&se, NULL);
2494 gfc_init_se (&lse, NULL);
2496 gfc_conv_expr (&se, expr);
2497 if (cm->ts.type == BT_CHARACTER)
2498 lse.string_length = cm->ts.cl->backend_decl;
2500 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2501 gfc_add_expr_to_block (&block, tmp);
2503 return gfc_finish_block (&block);
2506 /* Assign a derived type constructor to a variable. */
2509 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2517 gfc_start_block (&block);
2518 cm = expr->ts.derived->components;
2519 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2521 /* Skip absent members in default initializers. */
2525 field = cm->backend_decl;
2526 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2527 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2528 gfc_add_expr_to_block (&block, tmp);
2530 return gfc_finish_block (&block);
2533 /* Build an expression for a constructor. If init is nonzero then
2534 this is part of a static variable initializer. */
2537 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2544 VEC(constructor_elt,gc) *v = NULL;
2546 gcc_assert (se->ss == NULL);
2547 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2548 type = gfc_typenode_for_spec (&expr->ts);
2552 /* Create a temporary variable and fill it in. */
2553 se->expr = gfc_create_var (type, expr->ts.derived->name);
2554 tmp = gfc_trans_structure_assign (se->expr, expr);
2555 gfc_add_expr_to_block (&se->pre, tmp);
2559 cm = expr->ts.derived->components;
2560 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2562 /* Skip absent members in default initializers. */
2566 val = gfc_conv_initializer (c->expr, &cm->ts,
2567 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2569 /* Append it to the constructor list. */
2570 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2572 se->expr = build_constructor (type, v);
2576 /* Translate a substring expression. */
2579 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2585 gcc_assert (ref->type == REF_SUBSTRING);
2587 se->expr = gfc_build_string_const(expr->value.character.length,
2588 expr->value.character.string);
2589 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2590 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2592 gfc_conv_substring(se,ref,expr->ts.kind);
2596 /* Entry point for expression translation. Evaluates a scalar quantity.
2597 EXPR is the expression to be translated, and SE is the state structure if
2598 called from within the scalarized. */
2601 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2603 if (se->ss && se->ss->expr == expr
2604 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2606 /* Substitute a scalar expression evaluated outside the scalarization
2608 se->expr = se->ss->data.scalar.expr;
2609 se->string_length = se->ss->string_length;
2610 gfc_advance_se_ss_chain (se);
2614 switch (expr->expr_type)
2617 gfc_conv_expr_op (se, expr);
2621 gfc_conv_function_expr (se, expr);
2625 gfc_conv_constant (se, expr);
2629 gfc_conv_variable (se, expr);
2633 se->expr = null_pointer_node;
2636 case EXPR_SUBSTRING:
2637 gfc_conv_substring_expr (se, expr);
2640 case EXPR_STRUCTURE:
2641 gfc_conv_structure (se, expr, 0);
2645 gfc_conv_array_constructor_expr (se, expr);
2654 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2655 of an assignment. */
2657 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2659 gfc_conv_expr (se, expr);
2660 /* All numeric lvalues should have empty post chains. If not we need to
2661 figure out a way of rewriting an lvalue so that it has no post chain. */
2662 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2665 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2666 numeric expressions. Used for scalar values where inserting cleanup code
2669 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2673 gcc_assert (expr->ts.type != BT_CHARACTER);
2674 gfc_conv_expr (se, expr);
2677 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2678 gfc_add_modify_expr (&se->pre, val, se->expr);
2680 gfc_add_block_to_block (&se->pre, &se->post);
2684 /* Helper to translate and expression and convert it to a particular type. */
2686 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2688 gfc_conv_expr_val (se, expr);
2689 se->expr = convert (type, se->expr);
2693 /* Converts an expression so that it can be passed by reference. Scalar
2697 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2701 if (se->ss && se->ss->expr == expr
2702 && se->ss->type == GFC_SS_REFERENCE)
2704 se->expr = se->ss->data.scalar.expr;
2705 se->string_length = se->ss->string_length;
2706 gfc_advance_se_ss_chain (se);
2710 if (expr->ts.type == BT_CHARACTER)
2712 gfc_conv_expr (se, expr);
2713 gfc_conv_string_parameter (se);
2717 if (expr->expr_type == EXPR_VARIABLE)
2719 se->want_pointer = 1;
2720 gfc_conv_expr (se, expr);
2723 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2724 gfc_add_modify_expr (&se->pre, var, se->expr);
2725 gfc_add_block_to_block (&se->pre, &se->post);
2731 gfc_conv_expr (se, expr);
2733 /* Create a temporary var to hold the value. */
2734 if (TREE_CONSTANT (se->expr))
2736 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2737 DECL_INITIAL (var) = se->expr;
2742 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2743 gfc_add_modify_expr (&se->pre, var, se->expr);
2745 gfc_add_block_to_block (&se->pre, &se->post);
2747 /* Take the address of that value. */
2748 se->expr = build_fold_addr_expr (var);
2753 gfc_trans_pointer_assign (gfc_code * code)
2755 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2759 /* Generate code for a pointer assignment. */
2762 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2772 gfc_start_block (&block);
2774 gfc_init_se (&lse, NULL);
2776 lss = gfc_walk_expr (expr1);
2777 rss = gfc_walk_expr (expr2);
2778 if (lss == gfc_ss_terminator)
2780 /* Scalar pointers. */
2781 lse.want_pointer = 1;
2782 gfc_conv_expr (&lse, expr1);
2783 gcc_assert (rss == gfc_ss_terminator);
2784 gfc_init_se (&rse, NULL);
2785 rse.want_pointer = 1;
2786 gfc_conv_expr (&rse, expr2);
2787 gfc_add_block_to_block (&block, &lse.pre);
2788 gfc_add_block_to_block (&block, &rse.pre);
2789 gfc_add_modify_expr (&block, lse.expr,
2790 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2791 gfc_add_block_to_block (&block, &rse.post);
2792 gfc_add_block_to_block (&block, &lse.post);
2796 /* Array pointer. */
2797 gfc_conv_expr_descriptor (&lse, expr1, lss);
2798 switch (expr2->expr_type)
2801 /* Just set the data pointer to null. */
2802 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2806 /* Assign directly to the pointer's descriptor. */
2807 lse.direct_byref = 1;
2808 gfc_conv_expr_descriptor (&lse, expr2, rss);
2812 /* Assign to a temporary descriptor and then copy that
2813 temporary to the pointer. */
2815 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2818 lse.direct_byref = 1;
2819 gfc_conv_expr_descriptor (&lse, expr2, rss);
2820 gfc_add_modify_expr (&lse.pre, desc, tmp);
2823 gfc_add_block_to_block (&block, &lse.pre);
2824 gfc_add_block_to_block (&block, &lse.post);
2826 return gfc_finish_block (&block);
2830 /* Makes sure se is suitable for passing as a function string parameter. */
2831 /* TODO: Need to check all callers fo this function. It may be abused. */
2834 gfc_conv_string_parameter (gfc_se * se)
2838 if (TREE_CODE (se->expr) == STRING_CST)
2840 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2844 type = TREE_TYPE (se->expr);
2845 if (TYPE_STRING_FLAG (type))
2847 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2848 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2851 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2852 gcc_assert (se->string_length
2853 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2857 /* Generate code for assignment of scalar variables. Includes character
2861 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2865 gfc_init_block (&block);
2867 if (type == BT_CHARACTER)
2869 gcc_assert (lse->string_length != NULL_TREE
2870 && rse->string_length != NULL_TREE);
2872 gfc_conv_string_parameter (lse);
2873 gfc_conv_string_parameter (rse);
2875 gfc_add_block_to_block (&block, &lse->pre);
2876 gfc_add_block_to_block (&block, &rse->pre);
2878 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2879 rse->string_length, rse->expr);
2883 gfc_add_block_to_block (&block, &lse->pre);
2884 gfc_add_block_to_block (&block, &rse->pre);
2886 gfc_add_modify_expr (&block, lse->expr,
2887 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2890 gfc_add_block_to_block (&block, &lse->post);
2891 gfc_add_block_to_block (&block, &rse->post);
2893 return gfc_finish_block (&block);
2897 /* Try to translate array(:) = func (...), where func is a transformational
2898 array function, without using a temporary. Returns NULL is this isn't the
2902 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2907 bool seen_array_ref;
2909 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2910 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2913 /* Elemental functions don't need a temporary anyway. */
2914 if (expr2->value.function.esym != NULL
2915 && expr2->value.function.esym->attr.elemental)
2918 /* Fail if EXPR1 can't be expressed as a descriptor. */
2919 if (gfc_ref_needs_temporary_p (expr1->ref))
2922 /* Functions returning pointers need temporaries. */
2923 if (expr2->symtree->n.sym->attr.pointer)
2926 /* Check that no LHS component references appear during an array
2927 reference. This is needed because we do not have the means to
2928 span any arbitrary stride with an array descriptor. This check
2929 is not needed for the rhs because the function result has to be
2931 seen_array_ref = false;
2932 for (ref = expr1->ref; ref; ref = ref->next)
2934 if (ref->type == REF_ARRAY)
2935 seen_array_ref= true;
2936 else if (ref->type == REF_COMPONENT && seen_array_ref)
2940 /* Check for a dependency. */
2941 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
2942 expr2->value.function.esym,
2943 expr2->value.function.actual))
2946 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2948 gcc_assert (expr2->value.function.isym
2949 || (gfc_return_by_reference (expr2->value.function.esym)
2950 && expr2->value.function.esym->result->attr.dimension));
2952 ss = gfc_walk_expr (expr1);
2953 gcc_assert (ss != gfc_ss_terminator);
2954 gfc_init_se (&se, NULL);
2955 gfc_start_block (&se.pre);
2956 se.want_pointer = 1;
2958 gfc_conv_array_parameter (&se, expr1, ss, 0);
2960 se.direct_byref = 1;
2961 se.ss = gfc_walk_expr (expr2);
2962 gcc_assert (se.ss != gfc_ss_terminator);
2963 gfc_conv_function_expr (&se, expr2);
2964 gfc_add_block_to_block (&se.pre, &se.post);
2966 return gfc_finish_block (&se.pre);
2970 /* Translate an assignment. Most of the code is concerned with
2971 setting up the scalarizer. */
2974 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2979 gfc_ss *lss_section;
2986 /* Special case a single function returning an array. */
2987 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2989 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2994 /* Assignment of the form lhs = rhs. */
2995 gfc_start_block (&block);
2997 gfc_init_se (&lse, NULL);
2998 gfc_init_se (&rse, NULL);
3001 lss = gfc_walk_expr (expr1);
3003 if (lss != gfc_ss_terminator)
3005 /* The assignment needs scalarization. */
3008 /* Find a non-scalar SS from the lhs. */
3009 while (lss_section != gfc_ss_terminator
3010 && lss_section->type != GFC_SS_SECTION)
3011 lss_section = lss_section->next;
3013 gcc_assert (lss_section != gfc_ss_terminator);
3015 /* Initialize the scalarizer. */
3016 gfc_init_loopinfo (&loop);
3019 rss = gfc_walk_expr (expr2);
3020 if (rss == gfc_ss_terminator)
3022 /* The rhs is scalar. Add a ss for the expression. */
3023 rss = gfc_get_ss ();
3024 rss->next = gfc_ss_terminator;
3025 rss->type = GFC_SS_SCALAR;
3028 /* Associate the SS with the loop. */
3029 gfc_add_ss_to_loop (&loop, lss);
3030 gfc_add_ss_to_loop (&loop, rss);
3032 /* Calculate the bounds of the scalarization. */
3033 gfc_conv_ss_startstride (&loop);
3034 /* Resolve any data dependencies in the statement. */
3035 gfc_conv_resolve_dependencies (&loop, lss, rss);
3036 /* Setup the scalarizing loops. */
3037 gfc_conv_loop_setup (&loop);
3039 /* Setup the gfc_se structures. */
3040 gfc_copy_loopinfo_to_se (&lse, &loop);
3041 gfc_copy_loopinfo_to_se (&rse, &loop);
3044 gfc_mark_ss_chain_used (rss, 1);
3045 if (loop.temp_ss == NULL)
3048 gfc_mark_ss_chain_used (lss, 1);
3052 lse.ss = loop.temp_ss;
3053 gfc_mark_ss_chain_used (lss, 3);
3054 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3057 /* Start the scalarized loop body. */
3058 gfc_start_scalarized_body (&loop, &body);
3061 gfc_init_block (&body);
3063 /* Translate the expression. */
3064 gfc_conv_expr (&rse, expr2);
3066 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3068 gfc_conv_tmp_array_ref (&lse);
3069 gfc_advance_se_ss_chain (&lse);
3072 gfc_conv_expr (&lse, expr1);
3074 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3075 gfc_add_expr_to_block (&body, tmp);
3077 if (lss == gfc_ss_terminator)
3079 /* Use the scalar assignment as is. */
3080 gfc_add_block_to_block (&block, &body);
3084 gcc_assert (lse.ss == gfc_ss_terminator
3085 && rse.ss == gfc_ss_terminator);
3087 if (loop.temp_ss != NULL)
3089 gfc_trans_scalarized_loop_boundary (&loop, &body);
3091 /* We need to copy the temporary to the actual lhs. */
3092 gfc_init_se (&lse, NULL);
3093 gfc_init_se (&rse, NULL);
3094 gfc_copy_loopinfo_to_se (&lse, &loop);
3095 gfc_copy_loopinfo_to_se (&rse, &loop);
3097 rse.ss = loop.temp_ss;
3100 gfc_conv_tmp_array_ref (&rse);
3101 gfc_advance_se_ss_chain (&rse);
3102 gfc_conv_expr (&lse, expr1);
3104 gcc_assert (lse.ss == gfc_ss_terminator
3105 && rse.ss == gfc_ss_terminator);
3107 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3108 gfc_add_expr_to_block (&body, tmp);
3110 /* Generate the copying loops. */
3111 gfc_trans_scalarizing_loops (&loop, &body);
3113 /* Wrap the whole thing up. */
3114 gfc_add_block_to_block (&block, &loop.pre);
3115 gfc_add_block_to_block (&block, &loop.post);
3117 gfc_cleanup_loop (&loop);
3120 return gfc_finish_block (&block);
3124 gfc_trans_assign (gfc_code * code)
3126 return gfc_trans_assignment (code->expr, code->expr2);