1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005 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 = gfc_build_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);
250 build2 (MINUS_EXPR, gfc_charlen_type_node,
251 fold_convert (gfc_charlen_type_node, integer_one_node),
253 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
254 se->string_length = fold (tmp);
258 /* Convert a derived type component reference. */
261 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
268 c = ref->u.c.component;
270 gcc_assert (c->backend_decl);
272 field = c->backend_decl;
273 gcc_assert (TREE_CODE (field) == FIELD_DECL);
275 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
279 if (c->ts.type == BT_CHARACTER)
281 tmp = c->ts.cl->backend_decl;
282 /* Components must always be constant length. */
283 gcc_assert (tmp && INTEGER_CST_P (tmp));
284 se->string_length = tmp;
287 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
288 se->expr = gfc_build_indirect_ref (se->expr);
292 /* Return the contents of a variable. Also handles reference/pointer
293 variables (all Fortran pointer references are implicit). */
296 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
301 sym = expr->symtree->n.sym;
304 /* Check that something hasn't gone horribly wrong. */
305 gcc_assert (se->ss != gfc_ss_terminator);
306 gcc_assert (se->ss->expr == expr);
308 /* A scalarized term. We already know the descriptor. */
309 se->expr = se->ss->data.info.descriptor;
310 se->string_length = se->ss->string_length;
311 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
312 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
317 tree se_expr = NULL_TREE;
319 se->expr = gfc_get_symbol_decl (sym);
321 /* Special case for assigning the return value of a function.
322 Self recursive functions must have an explicit return value. */
323 if (se->expr == current_function_decl && sym->attr.function
324 && (sym->result == sym))
325 se_expr = gfc_get_fake_result_decl (sym);
327 /* Similarly for alternate entry points. */
328 else if (sym->attr.function && sym->attr.entry
329 && (sym->result == sym)
330 && sym->ns->proc_name->backend_decl == current_function_decl)
332 gfc_entry_list *el = NULL;
334 for (el = sym->ns->entries; el; el = el->next)
337 se_expr = gfc_get_fake_result_decl (sym);
342 else if (sym->attr.result
343 && sym->ns->proc_name->backend_decl == current_function_decl
344 && sym->ns->proc_name->attr.entry_master
345 && !gfc_return_by_reference (sym->ns->proc_name))
346 se_expr = gfc_get_fake_result_decl (sym);
351 /* Procedure actual arguments. */
352 else if (sym->attr.flavor == FL_PROCEDURE
353 && se->expr != current_function_decl)
355 gcc_assert (se->want_pointer);
356 if (!sym->attr.dummy)
358 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
359 se->expr = gfc_build_addr_expr (NULL, se->expr);
365 /* Dereference the expression, where needed. Since characters
366 are entirely different from other types, they are treated
368 if (sym->ts.type == BT_CHARACTER)
370 /* Dereference character pointer dummy arguments
372 if ((sym->attr.pointer || sym->attr.allocatable)
374 || sym->attr.function
375 || sym->attr.result))
376 se->expr = gfc_build_indirect_ref (se->expr);
380 /* Dereference non-character scalar dummy arguments. */
381 if (sym->attr.dummy && !sym->attr.dimension)
382 se->expr = gfc_build_indirect_ref (se->expr);
384 /* Dereference scalar hidden result. */
385 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
386 && (sym->attr.function || sym->attr.result)
387 && !sym->attr.dimension && !sym->attr.pointer)
388 se->expr = gfc_build_indirect_ref (se->expr);
390 /* Dereference non-character pointer variables.
391 These must be dummies, results, or scalars. */
392 if ((sym->attr.pointer || sym->attr.allocatable)
394 || sym->attr.function
396 || !sym->attr.dimension))
397 se->expr = gfc_build_indirect_ref (se->expr);
403 /* For character variables, also get the length. */
404 if (sym->ts.type == BT_CHARACTER)
406 se->string_length = sym->ts.cl->backend_decl;
407 gcc_assert (se->string_length);
415 /* Return the descriptor if that's what we want and this is an array
416 section reference. */
417 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
419 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
420 /* Return the descriptor for array pointers and allocations. */
422 && ref->next == NULL && (se->descriptor_only))
425 gfc_conv_array_ref (se, &ref->u.ar);
426 /* Return a pointer to an element. */
430 gfc_conv_component_ref (se, ref);
434 gfc_conv_substring (se, ref, expr->ts.kind);
443 /* Pointer assignment, allocation or pass by reference. Arrays are handled
445 if (se->want_pointer)
447 if (expr->ts.type == BT_CHARACTER)
448 gfc_conv_string_parameter (se);
450 se->expr = gfc_build_addr_expr (NULL, se->expr);
455 /* Unary ops are easy... Or they would be if ! was a valid op. */
458 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
463 gcc_assert (expr->ts.type != BT_CHARACTER);
464 /* Initialize the operand. */
465 gfc_init_se (&operand, se);
466 gfc_conv_expr_val (&operand, expr->value.op.op1);
467 gfc_add_block_to_block (&se->pre, &operand.pre);
469 type = gfc_typenode_for_spec (&expr->ts);
471 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
472 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
473 All other unary operators have an equivalent GIMPLE unary operator. */
474 if (code == TRUTH_NOT_EXPR)
475 se->expr = build2 (EQ_EXPR, type, operand.expr,
476 convert (type, integer_zero_node));
478 se->expr = build1 (code, type, operand.expr);
482 /* Expand power operator to optimal multiplications when a value is raised
483 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
484 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
485 Programming", 3rd Edition, 1998. */
487 /* This code is mostly duplicated from expand_powi in the backend.
488 We establish the "optimal power tree" lookup table with the defined size.
489 The items in the table are the exponents used to calculate the index
490 exponents. Any integer n less than the value can get an "addition chain",
491 with the first node being one. */
492 #define POWI_TABLE_SIZE 256
494 /* The table is from builtins.c. */
495 static const unsigned char powi_table[POWI_TABLE_SIZE] =
497 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
498 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
499 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
500 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
501 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
502 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
503 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
504 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
505 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
506 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
507 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
508 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
509 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
510 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
511 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
512 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
513 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
514 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
515 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
516 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
517 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
518 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
519 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
520 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
521 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
522 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
523 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
524 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
525 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
526 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
527 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
528 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
531 /* If n is larger than lookup table's max index, we use the "window
533 #define POWI_WINDOW_SIZE 3
535 /* Recursive function to expand the power operator. The temporary
536 values are put in tmpvar. The function returns tmpvar[1] ** n. */
538 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
545 if (n < POWI_TABLE_SIZE)
550 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
551 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
555 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
556 op0 = gfc_conv_powi (se, n - digit, tmpvar);
557 op1 = gfc_conv_powi (se, digit, tmpvar);
561 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
565 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
566 tmp = gfc_evaluate_now (tmp, &se->pre);
568 if (n < POWI_TABLE_SIZE)
575 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
576 return 1. Else return 0 and a call to runtime library functions
577 will have to be built. */
579 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
584 tree vartmp[POWI_TABLE_SIZE];
588 type = TREE_TYPE (lhs);
589 n = abs (TREE_INT_CST_LOW (rhs));
590 sgn = tree_int_cst_sgn (rhs);
592 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
593 && (n > 2 || n < -1))
599 se->expr = gfc_build_const (type, integer_one_node);
602 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
603 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
605 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
606 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
607 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
608 convert (TREE_TYPE (lhs), integer_one_node));
611 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
614 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
615 se->expr = build3 (COND_EXPR, type, tmp,
616 convert (type, integer_one_node),
617 convert (type, integer_zero_node));
621 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
622 tmp = build3 (COND_EXPR, type, tmp,
623 convert (type, integer_minus_one_node),
624 convert (type, integer_zero_node));
625 se->expr = build3 (COND_EXPR, type, cond,
626 convert (type, integer_one_node),
631 memset (vartmp, 0, sizeof (vartmp));
635 tmp = gfc_build_const (type, integer_one_node);
636 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
639 se->expr = gfc_conv_powi (se, n, vartmp);
645 /* Power op (**). Constant integer exponent has special handling. */
648 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
650 tree gfc_int4_type_node;
658 gfc_init_se (&lse, se);
659 gfc_conv_expr_val (&lse, expr->value.op.op1);
660 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
661 gfc_add_block_to_block (&se->pre, &lse.pre);
663 gfc_init_se (&rse, se);
664 gfc_conv_expr_val (&rse, expr->value.op.op2);
665 gfc_add_block_to_block (&se->pre, &rse.pre);
667 if (expr->value.op.op2->ts.type == BT_INTEGER
668 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
669 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
672 gfc_int4_type_node = gfc_get_int_type (4);
674 kind = expr->value.op.op1->ts.kind;
675 switch (expr->value.op.op2->ts.type)
678 ikind = expr->value.op.op2->ts.kind;
683 rse.expr = convert (gfc_int4_type_node, rse.expr);
705 if (expr->value.op.op1->ts.type == BT_INTEGER)
706 lse.expr = convert (gfc_int4_type_node, lse.expr);
731 switch (expr->value.op.op1->ts.type)
734 if (kind == 3) /* Case 16 was not handled properly above. */
736 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
740 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
744 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
756 fndecl = built_in_decls[BUILT_IN_POWF];
759 fndecl = built_in_decls[BUILT_IN_POW];
763 fndecl = built_in_decls[BUILT_IN_POWL];
774 fndecl = gfor_fndecl_math_cpowf;
777 fndecl = gfor_fndecl_math_cpow;
780 fndecl = gfor_fndecl_math_cpowl10;
783 fndecl = gfor_fndecl_math_cpowl16;
795 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
796 tmp = gfc_chainon_list (tmp, rse.expr);
797 se->expr = fold (gfc_build_function_call (fndecl, tmp));
801 /* Generate code to allocate a string temporary. */
804 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
810 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
812 if (gfc_can_put_var_on_stack (len))
814 /* Create a temporary variable to hold the result. */
815 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
816 convert (gfc_charlen_type_node, integer_one_node));
817 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
818 tmp = build_array_type (gfc_character1_type_node, tmp);
819 var = gfc_create_var (tmp, "str");
820 var = gfc_build_addr_expr (type, var);
824 /* Allocate a temporary to hold the result. */
825 var = gfc_create_var (type, "pstr");
826 args = gfc_chainon_list (NULL_TREE, len);
827 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
828 tmp = convert (type, tmp);
829 gfc_add_modify_expr (&se->pre, var, tmp);
831 /* Free the temporary afterwards. */
832 tmp = convert (pvoid_type_node, var);
833 args = gfc_chainon_list (NULL_TREE, tmp);
834 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
835 gfc_add_expr_to_block (&se->post, tmp);
842 /* Handle a string concatenation operation. A temporary will be allocated to
846 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
856 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
857 && expr->value.op.op2->ts.type == BT_CHARACTER);
859 gfc_init_se (&lse, se);
860 gfc_conv_expr (&lse, expr->value.op.op1);
861 gfc_conv_string_parameter (&lse);
862 gfc_init_se (&rse, se);
863 gfc_conv_expr (&rse, expr->value.op.op2);
864 gfc_conv_string_parameter (&rse);
866 gfc_add_block_to_block (&se->pre, &lse.pre);
867 gfc_add_block_to_block (&se->pre, &rse.pre);
869 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
870 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
871 if (len == NULL_TREE)
873 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
874 lse.string_length, rse.string_length);
877 type = build_pointer_type (type);
879 var = gfc_conv_string_tmp (se, type, len);
881 /* Do the actual concatenation. */
883 args = gfc_chainon_list (args, len);
884 args = gfc_chainon_list (args, var);
885 args = gfc_chainon_list (args, lse.string_length);
886 args = gfc_chainon_list (args, lse.expr);
887 args = gfc_chainon_list (args, rse.string_length);
888 args = gfc_chainon_list (args, rse.expr);
889 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
890 gfc_add_expr_to_block (&se->pre, tmp);
892 /* Add the cleanup for the operands. */
893 gfc_add_block_to_block (&se->pre, &rse.post);
894 gfc_add_block_to_block (&se->pre, &lse.post);
897 se->string_length = len;
901 /* Translates an op expression. Common (binary) cases are handled by this
902 function, others are passed on. Recursion is used in either case.
903 We use the fact that (op1.ts == op2.ts) (except for the power
905 Operators need no special handling for scalarized expressions as long as
906 they call gfc_conv_simple_val to get their operands.
907 Character strings get special handling. */
910 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
922 switch (expr->value.op.operator)
924 case INTRINSIC_UPLUS:
925 gfc_conv_expr (se, expr->value.op.op1);
928 case INTRINSIC_UMINUS:
929 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
933 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
940 case INTRINSIC_MINUS:
944 case INTRINSIC_TIMES:
948 case INTRINSIC_DIVIDE:
949 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
950 an integer, we must round towards zero, so we use a
952 if (expr->ts.type == BT_INTEGER)
953 code = TRUNC_DIV_EXPR;
958 case INTRINSIC_POWER:
959 gfc_conv_power_op (se, expr);
962 case INTRINSIC_CONCAT:
963 gfc_conv_concat_op (se, expr);
967 code = TRUTH_ANDIF_EXPR;
972 code = TRUTH_ORIF_EXPR;
976 /* EQV and NEQV only work on logicals, but since we represent them
977 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1016 case INTRINSIC_USER:
1017 case INTRINSIC_ASSIGN:
1018 /* These should be converted into function calls by the frontend. */
1022 fatal_error ("Unknown intrinsic op");
1026 /* The only exception to this is **, which is handled separately anyway. */
1027 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1029 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1033 gfc_init_se (&lse, se);
1034 gfc_conv_expr (&lse, expr->value.op.op1);
1035 gfc_add_block_to_block (&se->pre, &lse.pre);
1038 gfc_init_se (&rse, se);
1039 gfc_conv_expr (&rse, expr->value.op.op2);
1040 gfc_add_block_to_block (&se->pre, &rse.pre);
1042 /* For string comparisons we generate a library call, and compare the return
1046 gfc_conv_string_parameter (&lse);
1047 gfc_conv_string_parameter (&rse);
1049 tmp = gfc_chainon_list (tmp, lse.string_length);
1050 tmp = gfc_chainon_list (tmp, lse.expr);
1051 tmp = gfc_chainon_list (tmp, rse.string_length);
1052 tmp = gfc_chainon_list (tmp, rse.expr);
1054 /* Build a call for the comparison. */
1055 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1056 gfc_add_block_to_block (&lse.post, &rse.post);
1058 rse.expr = integer_zero_node;
1061 type = gfc_typenode_for_spec (&expr->ts);
1065 /* The result of logical ops is always boolean_type_node. */
1066 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1067 se->expr = convert (type, tmp);
1070 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1072 /* Add the post blocks. */
1073 gfc_add_block_to_block (&se->post, &rse.post);
1074 gfc_add_block_to_block (&se->post, &lse.post);
1079 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1083 if (sym->attr.dummy)
1085 tmp = gfc_get_symbol_decl (sym);
1086 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1087 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1091 if (!sym->backend_decl)
1092 sym->backend_decl = gfc_get_extern_function_decl (sym);
1094 tmp = sym->backend_decl;
1095 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1097 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1098 tmp = gfc_build_addr_expr (NULL, tmp);
1105 /* Initialize MAPPING. */
1108 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1110 mapping->syms = NULL;
1111 mapping->charlens = NULL;
1115 /* Free all memory held by MAPPING (but not MAPPING itself). */
1118 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1120 gfc_interface_sym_mapping *sym;
1121 gfc_interface_sym_mapping *nextsym;
1123 gfc_charlen *nextcl;
1125 for (sym = mapping->syms; sym; sym = nextsym)
1127 nextsym = sym->next;
1128 gfc_free_symbol (sym->new->n.sym);
1129 gfc_free (sym->new);
1132 for (cl = mapping->charlens; cl; cl = nextcl)
1135 gfc_free_expr (cl->length);
1141 /* Return a copy of gfc_charlen CL. Add the returned structure to
1142 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1144 static gfc_charlen *
1145 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1150 new = gfc_get_charlen ();
1151 new->next = mapping->charlens;
1152 new->length = gfc_copy_expr (cl->length);
1154 mapping->charlens = new;
1159 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1160 array variable that can be used as the actual argument for dummy
1161 argument SYM. Add any initialization code to BLOCK. PACKED is as
1162 for gfc_get_nodesc_array_type and DATA points to the first element
1163 in the passed array. */
1166 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1167 int packed, tree data)
1172 type = gfc_typenode_for_spec (&sym->ts);
1173 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1175 var = gfc_create_var (type, "parm");
1176 gfc_add_modify_expr (block, var, fold_convert (type, data));
1182 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1183 and offset of descriptorless array type TYPE given that it has the same
1184 size as DESC. Add any set-up code to BLOCK. */
1187 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1194 offset = gfc_index_zero_node;
1195 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1197 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1198 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1200 dim = gfc_rank_cst[n];
1201 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1202 gfc_conv_descriptor_ubound (desc, dim),
1203 gfc_conv_descriptor_lbound (desc, dim));
1204 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1205 GFC_TYPE_ARRAY_LBOUND (type, n),
1207 tmp = gfc_evaluate_now (tmp, block);
1208 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1210 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1211 GFC_TYPE_ARRAY_LBOUND (type, n),
1212 GFC_TYPE_ARRAY_STRIDE (type, n));
1213 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1215 offset = gfc_evaluate_now (offset, block);
1216 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1220 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1221 in SE. The caller may still use se->expr and se->string_length after
1222 calling this function. */
1225 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1226 gfc_symbol * sym, gfc_se * se)
1228 gfc_interface_sym_mapping *sm;
1232 gfc_symbol *new_sym;
1234 gfc_symtree *new_symtree;
1236 /* Create a new symbol to represent the actual argument. */
1237 new_sym = gfc_new_symbol (sym->name, NULL);
1238 new_sym->ts = sym->ts;
1239 new_sym->attr.referenced = 1;
1240 new_sym->attr.dimension = sym->attr.dimension;
1241 new_sym->attr.pointer = sym->attr.pointer;
1242 new_sym->attr.flavor = sym->attr.flavor;
1244 /* Create a fake symtree for it. */
1246 new_symtree = gfc_new_symtree (&root, sym->name);
1247 new_symtree->n.sym = new_sym;
1248 gcc_assert (new_symtree == root);
1250 /* Create a dummy->actual mapping. */
1251 sm = gfc_getmem (sizeof (*sm));
1252 sm->next = mapping->syms;
1254 sm->new = new_symtree;
1257 /* Stabilize the argument's value. */
1258 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1260 if (sym->ts.type == BT_CHARACTER)
1262 /* Create a copy of the dummy argument's length. */
1263 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1265 /* If the length is specified as "*", record the length that
1266 the caller is passing. We should use the callee's length
1267 in all other cases. */
1268 if (!new_sym->ts.cl->length)
1270 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1271 new_sym->ts.cl->backend_decl = se->string_length;
1275 /* Use the passed value as-is if the argument is a function. */
1276 if (sym->attr.flavor == FL_PROCEDURE)
1279 /* If the argument is either a string or a pointer to a string,
1280 convert it to a boundless character type. */
1281 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1283 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1284 tmp = build_pointer_type (tmp);
1285 if (sym->attr.pointer)
1286 tmp = build_pointer_type (tmp);
1288 value = fold_convert (tmp, se->expr);
1289 if (sym->attr.pointer)
1290 value = gfc_build_indirect_ref (value);
1293 /* If the argument is a scalar or a pointer to an array, dereference it. */
1294 else if (!sym->attr.dimension || sym->attr.pointer)
1295 value = gfc_build_indirect_ref (se->expr);
1297 /* If the argument is an array descriptor, use it to determine
1298 information about the actual argument's shape. */
1299 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1300 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1302 /* Get the actual argument's descriptor. */
1303 desc = gfc_build_indirect_ref (se->expr);
1305 /* Create the replacement variable. */
1306 tmp = gfc_conv_descriptor_data_get (desc);
1307 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1309 /* Use DESC to work out the upper bounds, strides and offset. */
1310 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1313 /* Otherwise we have a packed array. */
1314 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1316 new_sym->backend_decl = value;
1320 /* Called once all dummy argument mappings have been added to MAPPING,
1321 but before the mapping is used to evaluate expressions. Pre-evaluate
1322 the length of each argument, adding any initialization code to PRE and
1323 any finalization code to POST. */
1326 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1327 stmtblock_t * pre, stmtblock_t * post)
1329 gfc_interface_sym_mapping *sym;
1333 for (sym = mapping->syms; sym; sym = sym->next)
1334 if (sym->new->n.sym->ts.type == BT_CHARACTER
1335 && !sym->new->n.sym->ts.cl->backend_decl)
1337 expr = sym->new->n.sym->ts.cl->length;
1338 gfc_apply_interface_mapping_to_expr (mapping, expr);
1339 gfc_init_se (&se, NULL);
1340 gfc_conv_expr (&se, expr);
1342 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1343 gfc_add_block_to_block (pre, &se.pre);
1344 gfc_add_block_to_block (post, &se.post);
1346 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1351 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1355 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1356 gfc_constructor * c)
1358 for (; c; c = c->next)
1360 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1363 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1364 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1365 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1371 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1375 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1380 for (; ref; ref = ref->next)
1384 for (n = 0; n < ref->u.ar.dimen; n++)
1386 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1387 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1388 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1390 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1397 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1398 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1404 /* EXPR is a copy of an expression that appeared in the interface
1405 associated with MAPPING. Walk it recursively looking for references to
1406 dummy arguments that MAPPING maps to actual arguments. Replace each such
1407 reference with a reference to the associated actual argument. */
1410 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1413 gfc_interface_sym_mapping *sym;
1414 gfc_actual_arglist *actual;
1419 /* Copying an expression does not copy its length, so do that here. */
1420 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1422 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1423 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1426 /* Apply the mapping to any references. */
1427 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1429 /* ...and to the expression's symbol, if it has one. */
1431 for (sym = mapping->syms; sym; sym = sym->next)
1432 if (sym->old == expr->symtree->n.sym)
1433 expr->symtree = sym->new;
1435 /* ...and to subexpressions in expr->value. */
1436 switch (expr->expr_type)
1441 case EXPR_SUBSTRING:
1445 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1446 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1450 for (sym = mapping->syms; sym; sym = sym->next)
1451 if (sym->old == expr->value.function.esym)
1452 expr->value.function.esym = sym->new->n.sym;
1454 for (actual = expr->value.function.actual; actual; actual = actual->next)
1455 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1459 case EXPR_STRUCTURE:
1460 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1466 /* Evaluate interface expression EXPR using MAPPING. Store the result
1470 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1471 gfc_se * se, gfc_expr * expr)
1473 expr = gfc_copy_expr (expr);
1474 gfc_apply_interface_mapping_to_expr (mapping, expr);
1475 gfc_conv_expr (se, expr);
1476 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1477 gfc_free_expr (expr);
1481 /* Generate code for a procedure call. Note can return se->post != NULL.
1482 If se->direct_byref is set then se->expr contains the return parameter.
1483 Return nonzero, if the call has alternate specifiers. */
1486 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1487 gfc_actual_arglist * arg)
1489 gfc_interface_mapping mapping;
1502 gfc_formal_arglist *formal;
1503 int has_alternate_specifier = 0;
1504 bool need_interface_mapping;
1508 arglist = NULL_TREE;
1509 retargs = NULL_TREE;
1510 stringargs = NULL_TREE;
1516 if (!sym->attr.elemental)
1518 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1519 if (se->ss->useflags)
1521 gcc_assert (gfc_return_by_reference (sym)
1522 && sym->result->attr.dimension);
1523 gcc_assert (se->loop != NULL);
1525 /* Access the previously obtained result. */
1526 gfc_conv_tmp_array_ref (se);
1527 gfc_advance_se_ss_chain (se);
1531 info = &se->ss->data.info;
1536 gfc_init_interface_mapping (&mapping);
1537 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1538 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
1539 || sym->attr.dimension);
1540 formal = sym->formal;
1541 /* Evaluate the arguments. */
1542 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1544 if (arg->expr == NULL)
1547 if (se->ignore_optional)
1549 /* Some intrinsics have already been resolved to the correct
1553 else if (arg->label)
1555 has_alternate_specifier = 1;
1560 /* Pass a NULL pointer for an absent arg. */
1561 gfc_init_se (&parmse, NULL);
1562 parmse.expr = null_pointer_node;
1563 if (arg->missing_arg_type == BT_CHARACTER)
1564 parmse.string_length = convert (gfc_charlen_type_node,
1568 else if (se->ss && se->ss->useflags)
1570 /* An elemental function inside a scalarized loop. */
1571 gfc_init_se (&parmse, se);
1572 gfc_conv_expr_reference (&parmse, arg->expr);
1576 /* A scalar or transformational function. */
1577 gfc_init_se (&parmse, NULL);
1578 argss = gfc_walk_expr (arg->expr);
1580 if (argss == gfc_ss_terminator)
1582 gfc_conv_expr_reference (&parmse, arg->expr);
1583 if (formal && formal->sym->attr.pointer
1584 && arg->expr->expr_type != EXPR_NULL)
1586 /* Scalar pointer dummy args require an extra level of
1587 indirection. The null pointer already contains
1588 this level of indirection. */
1589 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1594 /* If the procedure requires an explicit interface, the
1595 actual argument is passed according to the
1596 corresponding formal argument. If the corresponding
1597 formal argument is a POINTER or assumed shape, we do
1598 not use g77's calling convention, and pass the
1599 address of the array descriptor instead. Otherwise we
1600 use g77's calling convention. */
1602 f = (formal != NULL)
1603 && !formal->sym->attr.pointer
1604 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1605 f = f || !sym->attr.always_explicit;
1606 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1610 if (formal && need_interface_mapping)
1611 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1613 gfc_add_block_to_block (&se->pre, &parmse.pre);
1614 gfc_add_block_to_block (&se->post, &parmse.post);
1616 /* Character strings are passed as two parameters, a length and a
1618 if (parmse.string_length != NULL_TREE)
1619 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1621 arglist = gfc_chainon_list (arglist, parmse.expr);
1623 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1626 if (ts.type == BT_CHARACTER)
1628 /* Calculate the length of the returned string. */
1629 gfc_init_se (&parmse, NULL);
1630 if (need_interface_mapping)
1631 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1633 gfc_conv_expr (&parmse, sym->ts.cl->length);
1634 gfc_add_block_to_block (&se->pre, &parmse.pre);
1635 gfc_add_block_to_block (&se->post, &parmse.post);
1637 /* Set up a charlen structure for it. */
1640 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1643 len = cl.backend_decl;
1646 byref = gfc_return_by_reference (sym);
1649 if (se->direct_byref)
1650 retargs = gfc_chainon_list (retargs, se->expr);
1651 else if (sym->result->attr.dimension)
1653 gcc_assert (se->loop && info);
1655 /* Set the type of the array. */
1656 tmp = gfc_typenode_for_spec (&ts);
1657 info->dimen = se->loop->dimen;
1659 /* Evaluate the bounds of the result, if known. */
1660 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1662 /* Allocate a temporary to store the result. */
1663 gfc_trans_allocate_temp_array (&se->pre, &se->post,
1664 se->loop, info, tmp, false);
1666 /* Zero the first stride to indicate a temporary. */
1667 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1668 gfc_add_modify_expr (&se->pre, tmp,
1669 convert (TREE_TYPE (tmp), integer_zero_node));
1671 /* Pass the temporary as the first argument. */
1672 tmp = info->descriptor;
1673 tmp = gfc_build_addr_expr (NULL, tmp);
1674 retargs = gfc_chainon_list (retargs, tmp);
1676 else if (ts.type == BT_CHARACTER)
1678 /* Pass the string length. */
1679 type = gfc_get_character_type (ts.kind, ts.cl);
1680 type = build_pointer_type (type);
1682 /* Return an address to a char[0:len-1]* temporary for
1683 character pointers. */
1684 if (sym->attr.pointer || sym->attr.allocatable)
1686 /* Build char[0:len-1] * pstr. */
1687 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1688 build_int_cst (gfc_charlen_type_node, 1));
1689 tmp = build_range_type (gfc_array_index_type,
1690 gfc_index_zero_node, tmp);
1691 tmp = build_array_type (gfc_character1_type_node, tmp);
1692 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1694 /* Provide an address expression for the function arguments. */
1695 var = gfc_build_addr_expr (NULL, var);
1698 var = gfc_conv_string_tmp (se, type, len);
1700 retargs = gfc_chainon_list (retargs, var);
1704 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1706 type = gfc_get_complex_type (ts.kind);
1707 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1708 retargs = gfc_chainon_list (retargs, var);
1711 /* Add the string length to the argument list. */
1712 if (ts.type == BT_CHARACTER)
1713 retargs = gfc_chainon_list (retargs, len);
1715 gfc_free_interface_mapping (&mapping);
1717 /* Add the return arguments. */
1718 arglist = chainon (retargs, arglist);
1720 /* Add the hidden string length parameters to the arguments. */
1721 arglist = chainon (arglist, stringargs);
1723 /* Generate the actual call. */
1724 gfc_conv_function_val (se, sym);
1725 /* If there are alternate return labels, function type should be
1726 integer. Can't modify the type in place though, since it can be shared
1727 with other functions. */
1728 if (has_alternate_specifier
1729 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1731 gcc_assert (! sym->attr.dummy);
1732 TREE_TYPE (sym->backend_decl)
1733 = build_function_type (integer_type_node,
1734 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1735 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1738 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1739 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1740 arglist, NULL_TREE);
1742 /* If we have a pointer function, but we don't want a pointer, e.g.
1745 where f is pointer valued, we have to dereference the result. */
1746 if (!se->want_pointer && !byref && sym->attr.pointer)
1747 se->expr = gfc_build_indirect_ref (se->expr);
1749 /* f2c calling conventions require a scalar default real function to
1750 return a double precision result. Convert this back to default
1751 real. We only care about the cases that can happen in Fortran 77.
1753 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1754 && sym->ts.kind == gfc_default_real_kind
1755 && !sym->attr.always_explicit)
1756 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1758 /* A pure function may still have side-effects - it may modify its
1760 TREE_SIDE_EFFECTS (se->expr) = 1;
1762 if (!sym->attr.pure)
1763 TREE_SIDE_EFFECTS (se->expr) = 1;
1768 /* Add the function call to the pre chain. There is no expression. */
1769 gfc_add_expr_to_block (&se->pre, se->expr);
1770 se->expr = NULL_TREE;
1772 if (!se->direct_byref)
1774 if (sym->attr.dimension)
1776 if (flag_bounds_check)
1778 /* Check the data pointer hasn't been modified. This would
1779 happen in a function returning a pointer. */
1780 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1781 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1782 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1784 se->expr = info->descriptor;
1785 /* Bundle in the string length. */
1786 se->string_length = len;
1788 else if (sym->ts.type == BT_CHARACTER)
1790 /* Dereference for character pointer results. */
1791 if (sym->attr.pointer || sym->attr.allocatable)
1792 se->expr = gfc_build_indirect_ref (var);
1796 se->string_length = len;
1800 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1801 se->expr = gfc_build_indirect_ref (var);
1806 return has_alternate_specifier;
1810 /* Generate code to copy a string. */
1813 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1814 tree slen, tree src)
1819 tmp = gfc_chainon_list (tmp, dlen);
1820 tmp = gfc_chainon_list (tmp, dest);
1821 tmp = gfc_chainon_list (tmp, slen);
1822 tmp = gfc_chainon_list (tmp, src);
1823 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1824 gfc_add_expr_to_block (block, tmp);
1828 /* Translate a statement function.
1829 The value of a statement function reference is obtained by evaluating the
1830 expression using the values of the actual arguments for the values of the
1831 corresponding dummy arguments. */
1834 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1838 gfc_formal_arglist *fargs;
1839 gfc_actual_arglist *args;
1842 gfc_saved_var *saved_vars;
1848 sym = expr->symtree->n.sym;
1849 args = expr->value.function.actual;
1850 gfc_init_se (&lse, NULL);
1851 gfc_init_se (&rse, NULL);
1854 for (fargs = sym->formal; fargs; fargs = fargs->next)
1856 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1857 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1859 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1861 /* Each dummy shall be specified, explicitly or implicitly, to be
1863 gcc_assert (fargs->sym->attr.dimension == 0);
1866 /* Create a temporary to hold the value. */
1867 type = gfc_typenode_for_spec (&fsym->ts);
1868 temp_vars[n] = gfc_create_var (type, fsym->name);
1870 if (fsym->ts.type == BT_CHARACTER)
1872 /* Copy string arguments. */
1875 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1876 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1878 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1879 tmp = gfc_build_addr_expr (build_pointer_type (type),
1882 gfc_conv_expr (&rse, args->expr);
1883 gfc_conv_string_parameter (&rse);
1884 gfc_add_block_to_block (&se->pre, &lse.pre);
1885 gfc_add_block_to_block (&se->pre, &rse.pre);
1887 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1889 gfc_add_block_to_block (&se->pre, &lse.post);
1890 gfc_add_block_to_block (&se->pre, &rse.post);
1894 /* For everything else, just evaluate the expression. */
1895 gfc_conv_expr (&lse, args->expr);
1897 gfc_add_block_to_block (&se->pre, &lse.pre);
1898 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1899 gfc_add_block_to_block (&se->pre, &lse.post);
1905 /* Use the temporary variables in place of the real ones. */
1906 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1907 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1909 gfc_conv_expr (se, sym->value);
1911 if (sym->ts.type == BT_CHARACTER)
1913 gfc_conv_const_charlen (sym->ts.cl);
1915 /* Force the expression to the correct length. */
1916 if (!INTEGER_CST_P (se->string_length)
1917 || tree_int_cst_lt (se->string_length,
1918 sym->ts.cl->backend_decl))
1920 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1921 tmp = gfc_create_var (type, sym->name);
1922 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1923 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1924 se->string_length, se->expr);
1927 se->string_length = sym->ts.cl->backend_decl;
1930 /* Restore the original variables. */
1931 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1932 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1933 gfc_free (saved_vars);
1937 /* Translate a function expression. */
1940 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1944 if (expr->value.function.isym)
1946 gfc_conv_intrinsic_function (se, expr);
1950 /* We distinguish statement functions from general functions to improve
1951 runtime performance. */
1952 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1954 gfc_conv_statement_function (se, expr);
1958 /* expr.value.function.esym is the resolved (specific) function symbol for
1959 most functions. However this isn't set for dummy procedures. */
1960 sym = expr->value.function.esym;
1962 sym = expr->symtree->n.sym;
1963 gfc_conv_function_call (se, sym, expr->value.function.actual);
1968 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1970 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1971 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1973 gfc_conv_tmp_array_ref (se);
1974 gfc_advance_se_ss_chain (se);
1978 /* Build a static initializer. EXPR is the expression for the initial value.
1979 The other parameters describe the variable of the component being
1980 initialized. EXPR may be null. */
1983 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1984 bool array, bool pointer)
1988 if (!(expr || pointer))
1993 /* Arrays need special handling. */
1995 return gfc_build_null_descriptor (type);
1997 return gfc_conv_array_initializer (type, expr);
2000 return fold_convert (type, null_pointer_node);
2006 gfc_init_se (&se, NULL);
2007 gfc_conv_structure (&se, expr, 1);
2011 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2014 gfc_init_se (&se, NULL);
2015 gfc_conv_constant (&se, expr);
2022 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2034 gfc_start_block (&block);
2036 /* Initialize the scalarizer. */
2037 gfc_init_loopinfo (&loop);
2039 gfc_init_se (&lse, NULL);
2040 gfc_init_se (&rse, NULL);
2043 rss = gfc_walk_expr (expr);
2044 if (rss == gfc_ss_terminator)
2046 /* The rhs is scalar. Add a ss for the expression. */
2047 rss = gfc_get_ss ();
2048 rss->next = gfc_ss_terminator;
2049 rss->type = GFC_SS_SCALAR;
2053 /* Create a SS for the destination. */
2054 lss = gfc_get_ss ();
2055 lss->type = GFC_SS_COMPONENT;
2057 lss->shape = gfc_get_shape (cm->as->rank);
2058 lss->next = gfc_ss_terminator;
2059 lss->data.info.dimen = cm->as->rank;
2060 lss->data.info.descriptor = dest;
2061 lss->data.info.data = gfc_conv_array_data (dest);
2062 lss->data.info.offset = gfc_conv_array_offset (dest);
2063 for (n = 0; n < cm->as->rank; n++)
2065 lss->data.info.dim[n] = n;
2066 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2067 lss->data.info.stride[n] = gfc_index_one_node;
2069 mpz_init (lss->shape[n]);
2070 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2071 cm->as->lower[n]->value.integer);
2072 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2075 /* Associate the SS with the loop. */
2076 gfc_add_ss_to_loop (&loop, lss);
2077 gfc_add_ss_to_loop (&loop, rss);
2079 /* Calculate the bounds of the scalarization. */
2080 gfc_conv_ss_startstride (&loop);
2082 /* Setup the scalarizing loops. */
2083 gfc_conv_loop_setup (&loop);
2085 /* Setup the gfc_se structures. */
2086 gfc_copy_loopinfo_to_se (&lse, &loop);
2087 gfc_copy_loopinfo_to_se (&rse, &loop);
2090 gfc_mark_ss_chain_used (rss, 1);
2092 gfc_mark_ss_chain_used (lss, 1);
2094 /* Start the scalarized loop body. */
2095 gfc_start_scalarized_body (&loop, &body);
2097 gfc_conv_tmp_array_ref (&lse);
2098 if (cm->ts.type == BT_CHARACTER)
2099 lse.string_length = cm->ts.cl->backend_decl;
2101 gfc_conv_expr (&rse, expr);
2103 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2104 gfc_add_expr_to_block (&body, tmp);
2106 gcc_assert (rse.ss == gfc_ss_terminator);
2108 /* Generate the copying loops. */
2109 gfc_trans_scalarizing_loops (&loop, &body);
2111 /* Wrap the whole thing up. */
2112 gfc_add_block_to_block (&block, &loop.pre);
2113 gfc_add_block_to_block (&block, &loop.post);
2115 for (n = 0; n < cm->as->rank; n++)
2116 mpz_clear (lss->shape[n]);
2117 gfc_free (lss->shape);
2119 gfc_cleanup_loop (&loop);
2121 return gfc_finish_block (&block);
2124 /* Assign a single component of a derived type constructor. */
2127 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2134 gfc_start_block (&block);
2137 gfc_init_se (&se, NULL);
2138 /* Pointer component. */
2141 /* Array pointer. */
2142 if (expr->expr_type == EXPR_NULL)
2143 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2146 rss = gfc_walk_expr (expr);
2147 se.direct_byref = 1;
2149 gfc_conv_expr_descriptor (&se, expr, rss);
2150 gfc_add_block_to_block (&block, &se.pre);
2151 gfc_add_block_to_block (&block, &se.post);
2156 /* Scalar pointers. */
2157 se.want_pointer = 1;
2158 gfc_conv_expr (&se, expr);
2159 gfc_add_block_to_block (&block, &se.pre);
2160 gfc_add_modify_expr (&block, dest,
2161 fold_convert (TREE_TYPE (dest), se.expr));
2162 gfc_add_block_to_block (&block, &se.post);
2165 else if (cm->dimension)
2167 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2168 gfc_add_expr_to_block (&block, tmp);
2170 else if (expr->ts.type == BT_DERIVED)
2172 /* Nested derived type. */
2173 tmp = gfc_trans_structure_assign (dest, expr);
2174 gfc_add_expr_to_block (&block, tmp);
2178 /* Scalar component. */
2181 gfc_init_se (&se, NULL);
2182 gfc_init_se (&lse, NULL);
2184 gfc_conv_expr (&se, expr);
2185 if (cm->ts.type == BT_CHARACTER)
2186 lse.string_length = cm->ts.cl->backend_decl;
2188 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2189 gfc_add_expr_to_block (&block, tmp);
2191 return gfc_finish_block (&block);
2194 /* Assign a derived type constructor to a variable. */
2197 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2205 gfc_start_block (&block);
2206 cm = expr->ts.derived->components;
2207 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2209 /* Skip absent members in default initializers. */
2213 field = cm->backend_decl;
2214 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2215 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2216 gfc_add_expr_to_block (&block, tmp);
2218 return gfc_finish_block (&block);
2221 /* Build an expression for a constructor. If init is nonzero then
2222 this is part of a static variable initializer. */
2225 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2232 VEC(constructor_elt,gc) *v = NULL;
2234 gcc_assert (se->ss == NULL);
2235 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2236 type = gfc_typenode_for_spec (&expr->ts);
2240 /* Create a temporary variable and fill it in. */
2241 se->expr = gfc_create_var (type, expr->ts.derived->name);
2242 tmp = gfc_trans_structure_assign (se->expr, expr);
2243 gfc_add_expr_to_block (&se->pre, tmp);
2247 cm = expr->ts.derived->components;
2248 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2250 /* Skip absent members in default initializers. */
2254 val = gfc_conv_initializer (c->expr, &cm->ts,
2255 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2257 /* Append it to the constructor list. */
2258 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2260 se->expr = build_constructor (type, v);
2264 /* Translate a substring expression. */
2267 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2273 gcc_assert (ref->type == REF_SUBSTRING);
2275 se->expr = gfc_build_string_const(expr->value.character.length,
2276 expr->value.character.string);
2277 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2278 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2280 gfc_conv_substring(se,ref,expr->ts.kind);
2284 /* Entry point for expression translation. Evaluates a scalar quantity.
2285 EXPR is the expression to be translated, and SE is the state structure if
2286 called from within the scalarized. */
2289 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2291 if (se->ss && se->ss->expr == expr
2292 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2294 /* Substitute a scalar expression evaluated outside the scalarization
2296 se->expr = se->ss->data.scalar.expr;
2297 se->string_length = se->ss->string_length;
2298 gfc_advance_se_ss_chain (se);
2302 switch (expr->expr_type)
2305 gfc_conv_expr_op (se, expr);
2309 gfc_conv_function_expr (se, expr);
2313 gfc_conv_constant (se, expr);
2317 gfc_conv_variable (se, expr);
2321 se->expr = null_pointer_node;
2324 case EXPR_SUBSTRING:
2325 gfc_conv_substring_expr (se, expr);
2328 case EXPR_STRUCTURE:
2329 gfc_conv_structure (se, expr, 0);
2333 gfc_conv_array_constructor_expr (se, expr);
2342 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2343 of an assignment. */
2345 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2347 gfc_conv_expr (se, expr);
2348 /* All numeric lvalues should have empty post chains. If not we need to
2349 figure out a way of rewriting an lvalue so that it has no post chain. */
2350 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2353 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2354 numeric expressions. Used for scalar values whee inserting cleanup code
2357 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2361 gcc_assert (expr->ts.type != BT_CHARACTER);
2362 gfc_conv_expr (se, expr);
2365 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2366 gfc_add_modify_expr (&se->pre, val, se->expr);
2368 gfc_add_block_to_block (&se->pre, &se->post);
2372 /* Helper to translate and expression and convert it to a particular type. */
2374 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2376 gfc_conv_expr_val (se, expr);
2377 se->expr = convert (type, se->expr);
2381 /* Converts an expression so that it can be passed by reference. Scalar
2385 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2389 if (se->ss && se->ss->expr == expr
2390 && se->ss->type == GFC_SS_REFERENCE)
2392 se->expr = se->ss->data.scalar.expr;
2393 se->string_length = se->ss->string_length;
2394 gfc_advance_se_ss_chain (se);
2398 if (expr->ts.type == BT_CHARACTER)
2400 gfc_conv_expr (se, expr);
2401 gfc_conv_string_parameter (se);
2405 if (expr->expr_type == EXPR_VARIABLE)
2407 se->want_pointer = 1;
2408 gfc_conv_expr (se, expr);
2411 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2412 gfc_add_modify_expr (&se->pre, var, se->expr);
2413 gfc_add_block_to_block (&se->pre, &se->post);
2419 gfc_conv_expr (se, expr);
2421 /* Create a temporary var to hold the value. */
2422 if (TREE_CONSTANT (se->expr))
2424 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2425 DECL_INITIAL (var) = se->expr;
2430 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2431 gfc_add_modify_expr (&se->pre, var, se->expr);
2433 gfc_add_block_to_block (&se->pre, &se->post);
2435 /* Take the address of that value. */
2436 se->expr = gfc_build_addr_expr (NULL, var);
2441 gfc_trans_pointer_assign (gfc_code * code)
2443 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2447 /* Generate code for a pointer assignment. */
2450 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2460 gfc_start_block (&block);
2462 gfc_init_se (&lse, NULL);
2464 lss = gfc_walk_expr (expr1);
2465 rss = gfc_walk_expr (expr2);
2466 if (lss == gfc_ss_terminator)
2468 /* Scalar pointers. */
2469 lse.want_pointer = 1;
2470 gfc_conv_expr (&lse, expr1);
2471 gcc_assert (rss == gfc_ss_terminator);
2472 gfc_init_se (&rse, NULL);
2473 rse.want_pointer = 1;
2474 gfc_conv_expr (&rse, expr2);
2475 gfc_add_block_to_block (&block, &lse.pre);
2476 gfc_add_block_to_block (&block, &rse.pre);
2477 gfc_add_modify_expr (&block, lse.expr,
2478 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2479 gfc_add_block_to_block (&block, &rse.post);
2480 gfc_add_block_to_block (&block, &lse.post);
2484 /* Array pointer. */
2485 gfc_conv_expr_descriptor (&lse, expr1, lss);
2486 switch (expr2->expr_type)
2489 /* Just set the data pointer to null. */
2490 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2494 /* Assign directly to the pointer's descriptor. */
2495 lse.direct_byref = 1;
2496 gfc_conv_expr_descriptor (&lse, expr2, rss);
2500 /* Assign to a temporary descriptor and then copy that
2501 temporary to the pointer. */
2503 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2506 lse.direct_byref = 1;
2507 gfc_conv_expr_descriptor (&lse, expr2, rss);
2508 gfc_add_modify_expr (&lse.pre, desc, tmp);
2511 gfc_add_block_to_block (&block, &lse.pre);
2512 gfc_add_block_to_block (&block, &lse.post);
2514 return gfc_finish_block (&block);
2518 /* Makes sure se is suitable for passing as a function string parameter. */
2519 /* TODO: Need to check all callers fo this function. It may be abused. */
2522 gfc_conv_string_parameter (gfc_se * se)
2526 if (TREE_CODE (se->expr) == STRING_CST)
2528 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2532 type = TREE_TYPE (se->expr);
2533 if (TYPE_STRING_FLAG (type))
2535 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2536 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2539 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2540 gcc_assert (se->string_length
2541 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2545 /* Generate code for assignment of scalar variables. Includes character
2549 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2553 gfc_init_block (&block);
2555 if (type == BT_CHARACTER)
2557 gcc_assert (lse->string_length != NULL_TREE
2558 && rse->string_length != NULL_TREE);
2560 gfc_conv_string_parameter (lse);
2561 gfc_conv_string_parameter (rse);
2563 gfc_add_block_to_block (&block, &lse->pre);
2564 gfc_add_block_to_block (&block, &rse->pre);
2566 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2567 rse->string_length, rse->expr);
2571 gfc_add_block_to_block (&block, &lse->pre);
2572 gfc_add_block_to_block (&block, &rse->pre);
2574 gfc_add_modify_expr (&block, lse->expr,
2575 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2578 gfc_add_block_to_block (&block, &lse->post);
2579 gfc_add_block_to_block (&block, &rse->post);
2581 return gfc_finish_block (&block);
2585 /* Try to translate array(:) = func (...), where func is a transformational
2586 array function, without using a temporary. Returns NULL is this isn't the
2590 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2595 bool seen_array_ref;
2597 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2598 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2601 /* Elemental functions don't need a temporary anyway. */
2602 if (expr2->value.function.esym != NULL
2603 && expr2->value.function.esym->attr.elemental)
2606 /* Fail if EXPR1 can't be expressed as a descriptor. */
2607 if (gfc_ref_needs_temporary_p (expr1->ref))
2610 /* Check that no LHS component references appear during an array
2611 reference. This is needed because we do not have the means to
2612 span any arbitrary stride with an array descriptor. This check
2613 is not needed for the rhs because the function result has to be
2615 seen_array_ref = false;
2616 for (ref = expr1->ref; ref; ref = ref->next)
2618 if (ref->type == REF_ARRAY)
2619 seen_array_ref= true;
2620 else if (ref->type == REF_COMPONENT && seen_array_ref)
2624 /* Check for a dependency. */
2625 if (gfc_check_fncall_dependency (expr1, expr2))
2628 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2630 gcc_assert (expr2->value.function.isym
2631 || (gfc_return_by_reference (expr2->value.function.esym)
2632 && expr2->value.function.esym->result->attr.dimension));
2634 ss = gfc_walk_expr (expr1);
2635 gcc_assert (ss != gfc_ss_terminator);
2636 gfc_init_se (&se, NULL);
2637 gfc_start_block (&se.pre);
2638 se.want_pointer = 1;
2640 gfc_conv_array_parameter (&se, expr1, ss, 0);
2642 se.direct_byref = 1;
2643 se.ss = gfc_walk_expr (expr2);
2644 gcc_assert (se.ss != gfc_ss_terminator);
2645 gfc_conv_function_expr (&se, expr2);
2646 gfc_add_block_to_block (&se.pre, &se.post);
2648 return gfc_finish_block (&se.pre);
2652 /* Translate an assignment. Most of the code is concerned with
2653 setting up the scalarizer. */
2656 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2661 gfc_ss *lss_section;
2668 /* Special case a single function returning an array. */
2669 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2671 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2676 /* Assignment of the form lhs = rhs. */
2677 gfc_start_block (&block);
2679 gfc_init_se (&lse, NULL);
2680 gfc_init_se (&rse, NULL);
2683 lss = gfc_walk_expr (expr1);
2685 if (lss != gfc_ss_terminator)
2687 /* The assignment needs scalarization. */
2690 /* Find a non-scalar SS from the lhs. */
2691 while (lss_section != gfc_ss_terminator
2692 && lss_section->type != GFC_SS_SECTION)
2693 lss_section = lss_section->next;
2695 gcc_assert (lss_section != gfc_ss_terminator);
2697 /* Initialize the scalarizer. */
2698 gfc_init_loopinfo (&loop);
2701 rss = gfc_walk_expr (expr2);
2702 if (rss == gfc_ss_terminator)
2704 /* The rhs is scalar. Add a ss for the expression. */
2705 rss = gfc_get_ss ();
2706 rss->next = gfc_ss_terminator;
2707 rss->type = GFC_SS_SCALAR;
2710 /* Associate the SS with the loop. */
2711 gfc_add_ss_to_loop (&loop, lss);
2712 gfc_add_ss_to_loop (&loop, rss);
2714 /* Calculate the bounds of the scalarization. */
2715 gfc_conv_ss_startstride (&loop);
2716 /* Resolve any data dependencies in the statement. */
2717 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2718 /* Setup the scalarizing loops. */
2719 gfc_conv_loop_setup (&loop);
2721 /* Setup the gfc_se structures. */
2722 gfc_copy_loopinfo_to_se (&lse, &loop);
2723 gfc_copy_loopinfo_to_se (&rse, &loop);
2726 gfc_mark_ss_chain_used (rss, 1);
2727 if (loop.temp_ss == NULL)
2730 gfc_mark_ss_chain_used (lss, 1);
2734 lse.ss = loop.temp_ss;
2735 gfc_mark_ss_chain_used (lss, 3);
2736 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2739 /* Start the scalarized loop body. */
2740 gfc_start_scalarized_body (&loop, &body);
2743 gfc_init_block (&body);
2745 /* Translate the expression. */
2746 gfc_conv_expr (&rse, expr2);
2748 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2750 gfc_conv_tmp_array_ref (&lse);
2751 gfc_advance_se_ss_chain (&lse);
2754 gfc_conv_expr (&lse, expr1);
2756 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2757 gfc_add_expr_to_block (&body, tmp);
2759 if (lss == gfc_ss_terminator)
2761 /* Use the scalar assignment as is. */
2762 gfc_add_block_to_block (&block, &body);
2766 gcc_assert (lse.ss == gfc_ss_terminator
2767 && rse.ss == gfc_ss_terminator);
2769 if (loop.temp_ss != NULL)
2771 gfc_trans_scalarized_loop_boundary (&loop, &body);
2773 /* We need to copy the temporary to the actual lhs. */
2774 gfc_init_se (&lse, NULL);
2775 gfc_init_se (&rse, NULL);
2776 gfc_copy_loopinfo_to_se (&lse, &loop);
2777 gfc_copy_loopinfo_to_se (&rse, &loop);
2779 rse.ss = loop.temp_ss;
2782 gfc_conv_tmp_array_ref (&rse);
2783 gfc_advance_se_ss_chain (&rse);
2784 gfc_conv_expr (&lse, expr1);
2786 gcc_assert (lse.ss == gfc_ss_terminator
2787 && rse.ss == gfc_ss_terminator);
2789 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2790 gfc_add_expr_to_block (&body, tmp);
2792 /* Generate the copying loops. */
2793 gfc_trans_scalarizing_loops (&loop, &body);
2795 /* Wrap the whole thing up. */
2796 gfc_add_block_to_block (&block, &loop.pre);
2797 gfc_add_block_to_block (&block, &loop.post);
2799 gfc_cleanup_loop (&loop);
2802 return gfc_finish_block (&block);
2806 gfc_trans_assign (gfc_code * code)
2808 return gfc_trans_assignment (code->expr, code->expr2);