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, 59 Temple Place - Suite 330, 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"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 /* Copy the scalarization loop variables. */
48 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
51 dest->loop = src->loop;
55 /* Initialize a simple expression holder.
57 Care must be taken when multiple se are created with the same parent.
58 The child se must be kept in sync. The easiest way is to delay creation
59 of a child se until after after the previous se has been translated. */
62 gfc_init_se (gfc_se * se, gfc_se * parent)
64 memset (se, 0, sizeof (gfc_se));
65 gfc_init_block (&se->pre);
66 gfc_init_block (&se->post);
71 gfc_copy_se_loopvars (se, parent);
75 /* Advances to the next SS in the chain. Use this rather than setting
76 se->ss = se->ss->next because all the parents needs to be kept in sync.
80 gfc_advance_se_ss_chain (gfc_se * se)
84 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
87 /* Walk down the parent chain. */
90 /* Simple consistency check. */
91 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
100 /* Ensures the result of the expression as either a temporary variable
101 or a constant so that it can be used repeatedly. */
104 gfc_make_safe_expr (gfc_se * se)
108 if (CONSTANT_CLASS_P (se->expr))
111 /* We need a temporary for this result. */
112 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
113 gfc_add_modify_expr (&se->pre, var, se->expr);
118 /* Return an expression which determines if a dummy parameter is present.
119 Also used for arguments to procedures with multiple entry points. */
122 gfc_conv_expr_present (gfc_symbol * sym)
126 gcc_assert (sym->attr.dummy);
128 decl = gfc_get_symbol_decl (sym);
129 if (TREE_CODE (decl) != PARM_DECL)
131 /* Array parameters use a temporary descriptor, we want the real
133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
134 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
135 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
137 return build2 (NE_EXPR, boolean_type_node, decl,
138 fold_convert (TREE_TYPE (decl), null_pointer_node));
142 /* Get the character length of an expression, looking through gfc_refs
146 gfc_get_expr_charlen (gfc_expr *e)
151 gcc_assert (e->expr_type == EXPR_VARIABLE
152 && e->ts.type == BT_CHARACTER);
154 length = NULL; /* To silence compiler warning. */
156 /* First candidate: if the variable is of type CHARACTER, the
157 expression's length could be the length of the character
159 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
160 length = e->symtree->n.sym->ts.cl->backend_decl;
162 /* Look through the reference chain for component references. */
163 for (r = e->ref; r; r = r->next)
168 if (r->u.c.component->ts.type == BT_CHARACTER)
169 length = r->u.c.component->ts.cl->backend_decl;
177 /* We should never got substring references here. These will be
178 broken down by the scalarizer. */
183 gcc_assert (length != NULL);
189 /* Generate code to initialize a string length variable. Returns the
193 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
198 gfc_init_se (&se, NULL);
199 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
200 gfc_add_block_to_block (pblock, &se.pre);
202 tmp = cl->backend_decl;
203 gfc_add_modify_expr (pblock, tmp, se.expr);
208 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
216 type = gfc_get_character_type (kind, ref->u.ss.length);
217 type = build_pointer_type (type);
220 gfc_init_se (&start, se);
221 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
222 gfc_add_block_to_block (&se->pre, &start.pre);
224 if (integer_onep (start.expr))
225 gfc_conv_string_parameter (se);
228 /* Change the start of the string. */
229 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
232 tmp = gfc_build_indirect_ref (se->expr);
233 tmp = gfc_build_array_ref (tmp, start.expr);
234 se->expr = gfc_build_addr_expr (type, tmp);
237 /* Length = end + 1 - start. */
238 gfc_init_se (&end, se);
239 if (ref->u.ss.end == NULL)
240 end.expr = se->string_length;
243 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
244 gfc_add_block_to_block (&se->pre, &end.pre);
247 build2 (MINUS_EXPR, gfc_charlen_type_node,
248 fold_convert (gfc_charlen_type_node, integer_one_node),
250 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
251 se->string_length = fold (tmp);
255 /* Convert a derived type component reference. */
258 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
265 c = ref->u.c.component;
267 gcc_assert (c->backend_decl);
269 field = c->backend_decl;
270 gcc_assert (TREE_CODE (field) == FIELD_DECL);
272 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
276 if (c->ts.type == BT_CHARACTER)
278 tmp = c->ts.cl->backend_decl;
279 /* Components must always be constant length. */
280 gcc_assert (tmp && INTEGER_CST_P (tmp));
281 se->string_length = tmp;
284 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
285 se->expr = gfc_build_indirect_ref (se->expr);
289 /* Return the contents of a variable. Also handles reference/pointer
290 variables (all Fortran pointer references are implicit). */
293 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
298 sym = expr->symtree->n.sym;
301 /* Check that something hasn't gone horribly wrong. */
302 gcc_assert (se->ss != gfc_ss_terminator);
303 gcc_assert (se->ss->expr == expr);
305 /* A scalarized term. We already know the descriptor. */
306 se->expr = se->ss->data.info.descriptor;
307 se->string_length = se->ss->string_length;
308 ref = se->ss->data.info.ref;
312 tree se_expr = NULL_TREE;
314 se->expr = gfc_get_symbol_decl (sym);
316 /* Special case for assigning the return value of a function.
317 Self recursive functions must have an explicit return value. */
318 if (se->expr == current_function_decl && sym->attr.function
319 && (sym->result == sym))
320 se_expr = gfc_get_fake_result_decl (sym);
322 /* Similarly for alternate entry points. */
323 else if (sym->attr.function && sym->attr.entry
324 && (sym->result == sym)
325 && sym->ns->proc_name->backend_decl == current_function_decl)
327 gfc_entry_list *el = NULL;
329 for (el = sym->ns->entries; el; el = el->next)
332 se_expr = gfc_get_fake_result_decl (sym);
337 else if (sym->attr.result
338 && sym->ns->proc_name->backend_decl == current_function_decl
339 && sym->ns->proc_name->attr.entry_master
340 && !gfc_return_by_reference (sym->ns->proc_name))
341 se_expr = gfc_get_fake_result_decl (sym);
346 /* Procedure actual arguments. */
347 else if (sym->attr.flavor == FL_PROCEDURE
348 && se->expr != current_function_decl)
350 gcc_assert (se->want_pointer);
351 if (!sym->attr.dummy)
353 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
354 se->expr = gfc_build_addr_expr (NULL, se->expr);
360 /* Dereference the expression, where needed. Since characters
361 are entirely different from other types, they are treated
363 if (sym->ts.type == BT_CHARACTER)
365 /* Dereference character pointer dummy arguments
367 if ((sym->attr.pointer || sym->attr.allocatable)
369 || sym->attr.function
370 || sym->attr.result))
371 se->expr = gfc_build_indirect_ref (se->expr);
375 /* Dereference non-character scalar dummy arguments. */
376 if (sym->attr.dummy && !sym->attr.dimension)
377 se->expr = gfc_build_indirect_ref (se->expr);
379 /* Dereference scalar hidden result. */
380 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
381 && (sym->attr.function || sym->attr.result)
382 && !sym->attr.dimension && !sym->attr.pointer)
383 se->expr = gfc_build_indirect_ref (se->expr);
385 /* Dereference non-character pointer variables.
386 These must be dummies, results, or scalars. */
387 if ((sym->attr.pointer || sym->attr.allocatable)
389 || sym->attr.function
391 || !sym->attr.dimension))
392 se->expr = gfc_build_indirect_ref (se->expr);
398 /* For character variables, also get the length. */
399 if (sym->ts.type == BT_CHARACTER)
401 se->string_length = sym->ts.cl->backend_decl;
402 gcc_assert (se->string_length);
410 /* Return the descriptor if that's what we want and this is an array
411 section reference. */
412 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
414 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
415 /* Return the descriptor for array pointers and allocations. */
417 && ref->next == NULL && (se->descriptor_only))
420 gfc_conv_array_ref (se, &ref->u.ar);
421 /* Return a pointer to an element. */
425 gfc_conv_component_ref (se, ref);
429 gfc_conv_substring (se, ref, expr->ts.kind);
438 /* Pointer assignment, allocation or pass by reference. Arrays are handled
440 if (se->want_pointer)
442 if (expr->ts.type == BT_CHARACTER)
443 gfc_conv_string_parameter (se);
445 se->expr = gfc_build_addr_expr (NULL, se->expr);
448 gfc_advance_se_ss_chain (se);
452 /* Unary ops are easy... Or they would be if ! was a valid op. */
455 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
460 gcc_assert (expr->ts.type != BT_CHARACTER);
461 /* Initialize the operand. */
462 gfc_init_se (&operand, se);
463 gfc_conv_expr_val (&operand, expr->value.op.op1);
464 gfc_add_block_to_block (&se->pre, &operand.pre);
466 type = gfc_typenode_for_spec (&expr->ts);
468 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
469 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
470 All other unary operators have an equivalent GIMPLE unary operator. */
471 if (code == TRUTH_NOT_EXPR)
472 se->expr = build2 (EQ_EXPR, type, operand.expr,
473 convert (type, integer_zero_node));
475 se->expr = build1 (code, type, operand.expr);
479 /* Expand power operator to optimal multiplications when a value is raised
480 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
481 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
482 Programming", 3rd Edition, 1998. */
484 /* This code is mostly duplicated from expand_powi in the backend.
485 We establish the "optimal power tree" lookup table with the defined size.
486 The items in the table are the exponents used to calculate the index
487 exponents. Any integer n less than the value can get an "addition chain",
488 with the first node being one. */
489 #define POWI_TABLE_SIZE 256
491 /* The table is from builtins.c. */
492 static const unsigned char powi_table[POWI_TABLE_SIZE] =
494 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
495 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
496 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
497 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
498 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
499 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
500 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
501 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
502 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
503 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
504 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
505 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
506 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
507 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
508 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
509 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
510 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
511 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
512 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
513 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
514 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
515 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
516 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
517 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
518 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
519 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
520 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
521 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
522 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
523 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
524 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
525 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
528 /* If n is larger than lookup table's max index, we use the "window
530 #define POWI_WINDOW_SIZE 3
532 /* Recursive function to expand the power operator. The temporary
533 values are put in tmpvar. The function returns tmpvar[1] ** n. */
535 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
542 if (n < POWI_TABLE_SIZE)
547 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
548 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
552 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
553 op0 = gfc_conv_powi (se, n - digit, tmpvar);
554 op1 = gfc_conv_powi (se, digit, tmpvar);
558 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
562 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
563 tmp = gfc_evaluate_now (tmp, &se->pre);
565 if (n < POWI_TABLE_SIZE)
572 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
573 return 1. Else return 0 and a call to runtime library functions
574 will have to be built. */
576 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
581 tree vartmp[POWI_TABLE_SIZE];
585 type = TREE_TYPE (lhs);
586 n = abs (TREE_INT_CST_LOW (rhs));
587 sgn = tree_int_cst_sgn (rhs);
589 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
590 && (n > 2 || n < -1))
596 se->expr = gfc_build_const (type, integer_one_node);
599 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
600 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
602 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
603 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
604 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
605 convert (TREE_TYPE (lhs), integer_one_node));
608 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
611 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
612 se->expr = build3 (COND_EXPR, type, tmp,
613 convert (type, integer_one_node),
614 convert (type, integer_zero_node));
618 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
619 tmp = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_minus_one_node),
621 convert (type, integer_zero_node));
622 se->expr = build3 (COND_EXPR, type, cond,
623 convert (type, integer_one_node),
628 memset (vartmp, 0, sizeof (vartmp));
632 tmp = gfc_build_const (type, integer_one_node);
633 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
636 se->expr = gfc_conv_powi (se, n, vartmp);
642 /* Power op (**). Constant integer exponent has special handling. */
645 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
647 tree gfc_int4_type_node;
655 gfc_init_se (&lse, se);
656 gfc_conv_expr_val (&lse, expr->value.op.op1);
657 gfc_add_block_to_block (&se->pre, &lse.pre);
659 gfc_init_se (&rse, se);
660 gfc_conv_expr_val (&rse, expr->value.op.op2);
661 gfc_add_block_to_block (&se->pre, &rse.pre);
663 if (expr->value.op.op2->ts.type == BT_INTEGER
664 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
665 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
668 gfc_int4_type_node = gfc_get_int_type (4);
670 kind = expr->value.op.op1->ts.kind;
671 switch (expr->value.op.op2->ts.type)
674 ikind = expr->value.op.op2->ts.kind;
679 rse.expr = convert (gfc_int4_type_node, rse.expr);
697 if (expr->value.op.op1->ts.type == BT_INTEGER)
698 lse.expr = convert (gfc_int4_type_node, lse.expr);
715 switch (expr->value.op.op1->ts.type)
718 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
722 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
726 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
738 fndecl = built_in_decls[BUILT_IN_POWF];
741 fndecl = built_in_decls[BUILT_IN_POW];
752 fndecl = gfor_fndecl_math_cpowf;
755 fndecl = gfor_fndecl_math_cpow;
767 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
768 tmp = gfc_chainon_list (tmp, rse.expr);
769 se->expr = fold (gfc_build_function_call (fndecl, tmp));
773 /* Generate code to allocate a string temporary. */
776 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
782 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
784 if (gfc_can_put_var_on_stack (len))
786 /* Create a temporary variable to hold the result. */
787 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
788 convert (gfc_charlen_type_node, integer_one_node));
789 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
790 tmp = build_array_type (gfc_character1_type_node, tmp);
791 var = gfc_create_var (tmp, "str");
792 var = gfc_build_addr_expr (type, var);
796 /* Allocate a temporary to hold the result. */
797 var = gfc_create_var (type, "pstr");
798 args = gfc_chainon_list (NULL_TREE, len);
799 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
800 tmp = convert (type, tmp);
801 gfc_add_modify_expr (&se->pre, var, tmp);
803 /* Free the temporary afterwards. */
804 tmp = convert (pvoid_type_node, var);
805 args = gfc_chainon_list (NULL_TREE, tmp);
806 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
807 gfc_add_expr_to_block (&se->post, tmp);
814 /* Handle a string concatenation operation. A temporary will be allocated to
818 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
828 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
829 && expr->value.op.op2->ts.type == BT_CHARACTER);
831 gfc_init_se (&lse, se);
832 gfc_conv_expr (&lse, expr->value.op.op1);
833 gfc_conv_string_parameter (&lse);
834 gfc_init_se (&rse, se);
835 gfc_conv_expr (&rse, expr->value.op.op2);
836 gfc_conv_string_parameter (&rse);
838 gfc_add_block_to_block (&se->pre, &lse.pre);
839 gfc_add_block_to_block (&se->pre, &rse.pre);
841 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
842 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
843 if (len == NULL_TREE)
845 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
846 lse.string_length, rse.string_length);
849 type = build_pointer_type (type);
851 var = gfc_conv_string_tmp (se, type, len);
853 /* Do the actual concatenation. */
855 args = gfc_chainon_list (args, len);
856 args = gfc_chainon_list (args, var);
857 args = gfc_chainon_list (args, lse.string_length);
858 args = gfc_chainon_list (args, lse.expr);
859 args = gfc_chainon_list (args, rse.string_length);
860 args = gfc_chainon_list (args, rse.expr);
861 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
862 gfc_add_expr_to_block (&se->pre, tmp);
864 /* Add the cleanup for the operands. */
865 gfc_add_block_to_block (&se->pre, &rse.post);
866 gfc_add_block_to_block (&se->pre, &lse.post);
869 se->string_length = len;
873 /* Translates an op expression. Common (binary) cases are handled by this
874 function, others are passed on. Recursion is used in either case.
875 We use the fact that (op1.ts == op2.ts) (except for the power
877 Operators need no special handling for scalarized expressions as long as
878 they call gfc_conv_simple_val to get their operands.
879 Character strings get special handling. */
882 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
894 switch (expr->value.op.operator)
896 case INTRINSIC_UPLUS:
897 gfc_conv_expr (se, expr->value.op.op1);
900 case INTRINSIC_UMINUS:
901 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
905 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
912 case INTRINSIC_MINUS:
916 case INTRINSIC_TIMES:
920 case INTRINSIC_DIVIDE:
921 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
922 an integer, we must round towards zero, so we use a
924 if (expr->ts.type == BT_INTEGER)
925 code = TRUNC_DIV_EXPR;
930 case INTRINSIC_POWER:
931 gfc_conv_power_op (se, expr);
934 case INTRINSIC_CONCAT:
935 gfc_conv_concat_op (se, expr);
939 code = TRUTH_ANDIF_EXPR;
944 code = TRUTH_ORIF_EXPR;
948 /* EQV and NEQV only work on logicals, but since we represent them
949 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
989 case INTRINSIC_ASSIGN:
990 /* These should be converted into function calls by the frontend. */
994 fatal_error ("Unknown intrinsic op");
998 /* The only exception to this is **, which is handled separately anyway. */
999 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1001 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1005 gfc_init_se (&lse, se);
1006 gfc_conv_expr (&lse, expr->value.op.op1);
1007 gfc_add_block_to_block (&se->pre, &lse.pre);
1010 gfc_init_se (&rse, se);
1011 gfc_conv_expr (&rse, expr->value.op.op2);
1012 gfc_add_block_to_block (&se->pre, &rse.pre);
1014 /* For string comparisons we generate a library call, and compare the return
1018 gfc_conv_string_parameter (&lse);
1019 gfc_conv_string_parameter (&rse);
1021 tmp = gfc_chainon_list (tmp, lse.string_length);
1022 tmp = gfc_chainon_list (tmp, lse.expr);
1023 tmp = gfc_chainon_list (tmp, rse.string_length);
1024 tmp = gfc_chainon_list (tmp, rse.expr);
1026 /* Build a call for the comparison. */
1027 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1028 gfc_add_block_to_block (&lse.post, &rse.post);
1030 rse.expr = integer_zero_node;
1033 type = gfc_typenode_for_spec (&expr->ts);
1037 /* The result of logical ops is always boolean_type_node. */
1038 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1039 se->expr = convert (type, tmp);
1042 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1044 /* Add the post blocks. */
1045 gfc_add_block_to_block (&se->post, &rse.post);
1046 gfc_add_block_to_block (&se->post, &lse.post);
1051 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1055 if (sym->attr.dummy)
1057 tmp = gfc_get_symbol_decl (sym);
1058 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1059 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1065 if (!sym->backend_decl)
1066 sym->backend_decl = gfc_get_extern_function_decl (sym);
1068 tmp = sym->backend_decl;
1069 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1070 se->expr = gfc_build_addr_expr (NULL, tmp);
1075 /* Generate code for a procedure call. Note can return se->post != NULL.
1076 If se->direct_byref is set then se->expr contains the return parameter.
1077 Return non-zero, if the call has alternate specifiers. */
1080 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1081 gfc_actual_arglist * arg)
1094 gfc_formal_arglist *formal;
1095 int has_alternate_specifier = 0;
1097 arglist = NULL_TREE;
1098 stringargs = NULL_TREE;
1102 /* Obtain the string length now because it is needed often below. */
1103 if (sym->ts.type == BT_CHARACTER)
1105 gcc_assert (sym->ts.cl && sym->ts.cl->length
1106 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1107 len = gfc_conv_mpz_to_tree
1108 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1113 if (!sym->attr.elemental)
1115 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1116 if (se->ss->useflags)
1118 gcc_assert (gfc_return_by_reference (sym)
1119 && sym->result->attr.dimension);
1120 gcc_assert (se->loop != NULL);
1122 /* Access the previously obtained result. */
1123 gfc_conv_tmp_array_ref (se);
1124 gfc_advance_se_ss_chain (se);
1126 /* Bundle in the string length. */
1127 se->string_length = len;
1131 info = &se->ss->data.info;
1136 byref = gfc_return_by_reference (sym);
1139 if (se->direct_byref)
1141 arglist = gfc_chainon_list (arglist, se->expr);
1143 /* Add string length to argument list. */
1144 if (sym->ts.type == BT_CHARACTER)
1146 sym->ts.cl->backend_decl = len;
1147 arglist = gfc_chainon_list (arglist,
1148 convert (gfc_charlen_type_node, len));
1151 else if (sym->result->attr.dimension)
1153 gcc_assert (se->loop && se->ss);
1155 /* Set the type of the array. */
1156 tmp = gfc_typenode_for_spec (&sym->ts);
1157 info->dimen = se->loop->dimen;
1159 /* Allocate a temporary to store the result. */
1160 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1162 /* Zero the first stride to indicate a temporary. */
1164 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1165 gfc_add_modify_expr (&se->pre, tmp,
1166 convert (TREE_TYPE (tmp), integer_zero_node));
1168 /* Pass the temporary as the first argument. */
1169 tmp = info->descriptor;
1170 tmp = gfc_build_addr_expr (NULL, tmp);
1171 arglist = gfc_chainon_list (arglist, tmp);
1173 /* Add string length to argument list. */
1174 if (sym->ts.type == BT_CHARACTER)
1176 sym->ts.cl->backend_decl = len;
1177 arglist = gfc_chainon_list (arglist,
1178 convert (gfc_charlen_type_node, len));
1182 else if (sym->ts.type == BT_CHARACTER)
1185 /* Pass the string length. */
1186 sym->ts.cl->backend_decl = len;
1187 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1188 type = build_pointer_type (type);
1190 /* Return an address to a char[0:len-1]* temporary for character pointers. */
1191 if (sym->attr.pointer || sym->attr.allocatable)
1193 /* Build char[0:len-1] * pstr. */
1194 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1195 build_int_cst (gfc_charlen_type_node, 1));
1196 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1197 tmp = build_array_type (gfc_character1_type_node, tmp);
1198 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1200 /* Provide an address expression for the function arguments. */
1201 var = gfc_build_addr_expr (NULL, var);
1205 var = gfc_conv_string_tmp (se, type, len);
1207 arglist = gfc_chainon_list (arglist, var);
1208 arglist = gfc_chainon_list (arglist,
1209 convert (gfc_charlen_type_node, len));
1213 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1215 type = gfc_get_complex_type (sym->ts.kind);
1216 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1217 arglist = gfc_chainon_list (arglist, var);
1221 formal = sym->formal;
1222 /* Evaluate the arguments. */
1223 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1225 if (arg->expr == NULL)
1228 if (se->ignore_optional)
1230 /* Some intrinsics have already been resolved to the correct
1234 else if (arg->label)
1236 has_alternate_specifier = 1;
1241 /* Pass a NULL pointer for an absent arg. */
1242 gfc_init_se (&parmse, NULL);
1243 parmse.expr = null_pointer_node;
1244 if (arg->missing_arg_type == BT_CHARACTER)
1247 gfc_chainon_list (stringargs,
1248 convert (gfc_charlen_type_node,
1249 integer_zero_node));
1253 else if (se->ss && se->ss->useflags)
1255 /* An elemental function inside a scalarized loop. */
1256 gfc_init_se (&parmse, se);
1257 gfc_conv_expr_reference (&parmse, arg->expr);
1261 /* A scalar or transformational function. */
1262 gfc_init_se (&parmse, NULL);
1263 argss = gfc_walk_expr (arg->expr);
1265 if (argss == gfc_ss_terminator)
1267 gfc_conv_expr_reference (&parmse, arg->expr);
1268 if (formal && formal->sym->attr.pointer
1269 && arg->expr->expr_type != EXPR_NULL)
1271 /* Scalar pointer dummy args require an extra level of
1272 indirection. The null pointer already contains
1273 this level of indirection. */
1274 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1279 /* If the procedure requires an explicit interface, the
1280 actual argument is passed according to the
1281 corresponding formal argument. If the corresponding
1282 formal argument is a POINTER or assumed shape, we do
1283 not use g77's calling convention, and pass the
1284 address of the array descriptor instead. Otherwise we
1285 use g77's calling convention. */
1287 f = (formal != NULL)
1288 && !formal->sym->attr.pointer
1289 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1290 f = f || !sym->attr.always_explicit;
1291 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1295 gfc_add_block_to_block (&se->pre, &parmse.pre);
1296 gfc_add_block_to_block (&se->post, &parmse.post);
1298 /* Character strings are passed as two parameters, a length and a
1300 if (parmse.string_length != NULL_TREE)
1301 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1303 arglist = gfc_chainon_list (arglist, parmse.expr);
1306 /* Add the hidden string length parameters to the arguments. */
1307 arglist = chainon (arglist, stringargs);
1309 /* Generate the actual call. */
1310 gfc_conv_function_val (se, sym);
1311 /* If there are alternate return labels, function type should be
1312 integer. Can't modify the type in place though, since it can be shared
1313 with other functions. */
1314 if (has_alternate_specifier
1315 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1317 gcc_assert (! sym->attr.dummy);
1318 TREE_TYPE (sym->backend_decl)
1319 = build_function_type (integer_type_node,
1320 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1321 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1324 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1325 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1326 arglist, NULL_TREE);
1328 /* If we have a pointer function, but we don't want a pointer, e.g.
1331 where f is pointer valued, we have to dereference the result. */
1332 if (!se->want_pointer && !byref && sym->attr.pointer)
1333 se->expr = gfc_build_indirect_ref (se->expr);
1335 /* f2c calling conventions require a scalar default real function to
1336 return a double precision result. Convert this back to default
1337 real. We only care about the cases that can happen in Fortran 77.
1339 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1340 && sym->ts.kind == gfc_default_real_kind
1341 && !sym->attr.always_explicit)
1342 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1344 /* A pure function may still have side-effects - it may modify its
1346 TREE_SIDE_EFFECTS (se->expr) = 1;
1348 if (!sym->attr.pure)
1349 TREE_SIDE_EFFECTS (se->expr) = 1;
1354 /* Add the function call to the pre chain. There is no expression. */
1355 gfc_add_expr_to_block (&se->pre, se->expr);
1356 se->expr = NULL_TREE;
1358 if (!se->direct_byref)
1360 if (sym->attr.dimension)
1362 if (flag_bounds_check)
1364 /* Check the data pointer hasn't been modified. This would
1365 happen in a function returning a pointer. */
1366 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1367 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1368 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1370 se->expr = info->descriptor;
1371 /* Bundle in the string length. */
1372 se->string_length = len;
1374 else if (sym->ts.type == BT_CHARACTER)
1376 /* Dereference for character pointer results. */
1377 if (sym->attr.pointer || sym->attr.allocatable)
1378 se->expr = gfc_build_indirect_ref (var);
1382 se->string_length = len;
1386 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1387 se->expr = gfc_build_indirect_ref (var);
1392 return has_alternate_specifier;
1396 /* Generate code to copy a string. */
1399 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1400 tree slen, tree src)
1405 tmp = gfc_chainon_list (tmp, dlen);
1406 tmp = gfc_chainon_list (tmp, dest);
1407 tmp = gfc_chainon_list (tmp, slen);
1408 tmp = gfc_chainon_list (tmp, src);
1409 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1410 gfc_add_expr_to_block (block, tmp);
1414 /* Translate a statement function.
1415 The value of a statement function reference is obtained by evaluating the
1416 expression using the values of the actual arguments for the values of the
1417 corresponding dummy arguments. */
1420 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1424 gfc_formal_arglist *fargs;
1425 gfc_actual_arglist *args;
1428 gfc_saved_var *saved_vars;
1434 sym = expr->symtree->n.sym;
1435 args = expr->value.function.actual;
1436 gfc_init_se (&lse, NULL);
1437 gfc_init_se (&rse, NULL);
1440 for (fargs = sym->formal; fargs; fargs = fargs->next)
1442 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1443 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1445 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1447 /* Each dummy shall be specified, explicitly or implicitly, to be
1449 gcc_assert (fargs->sym->attr.dimension == 0);
1452 /* Create a temporary to hold the value. */
1453 type = gfc_typenode_for_spec (&fsym->ts);
1454 temp_vars[n] = gfc_create_var (type, fsym->name);
1456 if (fsym->ts.type == BT_CHARACTER)
1458 /* Copy string arguments. */
1461 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1462 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1464 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1465 tmp = gfc_build_addr_expr (build_pointer_type (type),
1468 gfc_conv_expr (&rse, args->expr);
1469 gfc_conv_string_parameter (&rse);
1470 gfc_add_block_to_block (&se->pre, &lse.pre);
1471 gfc_add_block_to_block (&se->pre, &rse.pre);
1473 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1475 gfc_add_block_to_block (&se->pre, &lse.post);
1476 gfc_add_block_to_block (&se->pre, &rse.post);
1480 /* For everything else, just evaluate the expression. */
1481 gfc_conv_expr (&lse, args->expr);
1483 gfc_add_block_to_block (&se->pre, &lse.pre);
1484 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1485 gfc_add_block_to_block (&se->pre, &lse.post);
1491 /* Use the temporary variables in place of the real ones. */
1492 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1493 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1495 gfc_conv_expr (se, sym->value);
1497 if (sym->ts.type == BT_CHARACTER)
1499 gfc_conv_const_charlen (sym->ts.cl);
1501 /* Force the expression to the correct length. */
1502 if (!INTEGER_CST_P (se->string_length)
1503 || tree_int_cst_lt (se->string_length,
1504 sym->ts.cl->backend_decl))
1506 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1507 tmp = gfc_create_var (type, sym->name);
1508 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1509 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1510 se->string_length, se->expr);
1513 se->string_length = sym->ts.cl->backend_decl;
1516 /* Restore the original variables. */
1517 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1518 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1519 gfc_free (saved_vars);
1523 /* Translate a function expression. */
1526 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1530 if (expr->value.function.isym)
1532 gfc_conv_intrinsic_function (se, expr);
1536 /* We distinguish statement functions from general functions to improve
1537 runtime performance. */
1538 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1540 gfc_conv_statement_function (se, expr);
1544 /* expr.value.function.esym is the resolved (specific) function symbol for
1545 most functions. However this isn't set for dummy procedures. */
1546 sym = expr->value.function.esym;
1548 sym = expr->symtree->n.sym;
1549 gfc_conv_function_call (se, sym, expr->value.function.actual);
1554 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1556 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1557 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1559 gfc_conv_tmp_array_ref (se);
1560 gfc_advance_se_ss_chain (se);
1564 /* Build a static initializer. EXPR is the expression for the initial value.
1565 The other parameters describe the variable of the component being
1566 initialized. EXPR may be null. */
1569 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1570 bool array, bool pointer)
1574 if (!(expr || pointer))
1579 /* Arrays need special handling. */
1581 return gfc_build_null_descriptor (type);
1583 return gfc_conv_array_initializer (type, expr);
1586 return fold_convert (type, null_pointer_node);
1592 gfc_init_se (&se, NULL);
1593 gfc_conv_structure (&se, expr, 1);
1597 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1600 gfc_init_se (&se, NULL);
1601 gfc_conv_constant (&se, expr);
1608 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1620 gfc_start_block (&block);
1622 /* Initialize the scalarizer. */
1623 gfc_init_loopinfo (&loop);
1625 gfc_init_se (&lse, NULL);
1626 gfc_init_se (&rse, NULL);
1629 rss = gfc_walk_expr (expr);
1630 if (rss == gfc_ss_terminator)
1632 /* The rhs is scalar. Add a ss for the expression. */
1633 rss = gfc_get_ss ();
1634 rss->next = gfc_ss_terminator;
1635 rss->type = GFC_SS_SCALAR;
1639 /* Create a SS for the destination. */
1640 lss = gfc_get_ss ();
1641 lss->type = GFC_SS_COMPONENT;
1643 lss->shape = gfc_get_shape (cm->as->rank);
1644 lss->next = gfc_ss_terminator;
1645 lss->data.info.dimen = cm->as->rank;
1646 lss->data.info.descriptor = dest;
1647 lss->data.info.data = gfc_conv_array_data (dest);
1648 lss->data.info.offset = gfc_conv_array_offset (dest);
1649 for (n = 0; n < cm->as->rank; n++)
1651 lss->data.info.dim[n] = n;
1652 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1653 lss->data.info.stride[n] = gfc_index_one_node;
1655 mpz_init (lss->shape[n]);
1656 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1657 cm->as->lower[n]->value.integer);
1658 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1661 /* Associate the SS with the loop. */
1662 gfc_add_ss_to_loop (&loop, lss);
1663 gfc_add_ss_to_loop (&loop, rss);
1665 /* Calculate the bounds of the scalarization. */
1666 gfc_conv_ss_startstride (&loop);
1668 /* Setup the scalarizing loops. */
1669 gfc_conv_loop_setup (&loop);
1671 /* Setup the gfc_se structures. */
1672 gfc_copy_loopinfo_to_se (&lse, &loop);
1673 gfc_copy_loopinfo_to_se (&rse, &loop);
1676 gfc_mark_ss_chain_used (rss, 1);
1678 gfc_mark_ss_chain_used (lss, 1);
1680 /* Start the scalarized loop body. */
1681 gfc_start_scalarized_body (&loop, &body);
1683 gfc_conv_tmp_array_ref (&lse);
1684 if (cm->ts.type == BT_CHARACTER)
1685 lse.string_length = cm->ts.cl->backend_decl;
1687 gfc_conv_expr (&rse, expr);
1689 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1690 gfc_add_expr_to_block (&body, tmp);
1692 gcc_assert (rse.ss == gfc_ss_terminator);
1694 /* Generate the copying loops. */
1695 gfc_trans_scalarizing_loops (&loop, &body);
1697 /* Wrap the whole thing up. */
1698 gfc_add_block_to_block (&block, &loop.pre);
1699 gfc_add_block_to_block (&block, &loop.post);
1701 for (n = 0; n < cm->as->rank; n++)
1702 mpz_clear (lss->shape[n]);
1703 gfc_free (lss->shape);
1705 gfc_cleanup_loop (&loop);
1707 return gfc_finish_block (&block);
1710 /* Assign a single component of a derived type constructor. */
1713 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1720 gfc_start_block (&block);
1723 gfc_init_se (&se, NULL);
1724 /* Pointer component. */
1727 /* Array pointer. */
1728 if (expr->expr_type == EXPR_NULL)
1729 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
1732 rss = gfc_walk_expr (expr);
1733 se.direct_byref = 1;
1735 gfc_conv_expr_descriptor (&se, expr, rss);
1736 gfc_add_block_to_block (&block, &se.pre);
1737 gfc_add_block_to_block (&block, &se.post);
1742 /* Scalar pointers. */
1743 se.want_pointer = 1;
1744 gfc_conv_expr (&se, expr);
1745 gfc_add_block_to_block (&block, &se.pre);
1746 gfc_add_modify_expr (&block, dest,
1747 fold_convert (TREE_TYPE (dest), se.expr));
1748 gfc_add_block_to_block (&block, &se.post);
1751 else if (cm->dimension)
1753 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1754 gfc_add_expr_to_block (&block, tmp);
1756 else if (expr->ts.type == BT_DERIVED)
1758 /* Nested derived type. */
1759 tmp = gfc_trans_structure_assign (dest, expr);
1760 gfc_add_expr_to_block (&block, tmp);
1764 /* Scalar component. */
1767 gfc_init_se (&se, NULL);
1768 gfc_init_se (&lse, NULL);
1770 gfc_conv_expr (&se, expr);
1771 if (cm->ts.type == BT_CHARACTER)
1772 lse.string_length = cm->ts.cl->backend_decl;
1774 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1775 gfc_add_expr_to_block (&block, tmp);
1777 return gfc_finish_block (&block);
1780 /* Assign a derived type constructor to a variable. */
1783 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1791 gfc_start_block (&block);
1792 cm = expr->ts.derived->components;
1793 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1795 /* Skip absent members in default initializers. */
1799 field = cm->backend_decl;
1800 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1801 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1802 gfc_add_expr_to_block (&block, tmp);
1804 return gfc_finish_block (&block);
1807 /* Build an expression for a constructor. If init is nonzero then
1808 this is part of a static variable initializer. */
1811 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1821 gcc_assert (se->ss == NULL);
1822 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1823 type = gfc_typenode_for_spec (&expr->ts);
1827 /* Create a temporary variable and fill it in. */
1828 se->expr = gfc_create_var (type, expr->ts.derived->name);
1829 tmp = gfc_trans_structure_assign (se->expr, expr);
1830 gfc_add_expr_to_block (&se->pre, tmp);
1834 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1837 cm = expr->ts.derived->components;
1838 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1840 /* Skip absent members in default initializers. */
1844 val = gfc_conv_initializer (c->expr, &cm->ts,
1845 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1847 /* Build a TREE_CHAIN to hold it. */
1848 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1850 /* Add it to the list. */
1851 if (tail == NULL_TREE)
1852 TREE_OPERAND(head, 0) = tail = val;
1855 TREE_CHAIN (tail) = val;
1863 /* Translate a substring expression. */
1866 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1872 gcc_assert (ref->type == REF_SUBSTRING);
1874 se->expr = gfc_build_string_const(expr->value.character.length,
1875 expr->value.character.string);
1876 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1877 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1879 gfc_conv_substring(se,ref,expr->ts.kind);
1883 /* Entry point for expression translation. */
1886 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1888 if (se->ss && se->ss->expr == expr
1889 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1891 /* Substitute a scalar expression evaluated outside the scalarization
1893 se->expr = se->ss->data.scalar.expr;
1894 se->string_length = se->ss->string_length;
1895 gfc_advance_se_ss_chain (se);
1899 switch (expr->expr_type)
1902 gfc_conv_expr_op (se, expr);
1906 gfc_conv_function_expr (se, expr);
1910 gfc_conv_constant (se, expr);
1914 gfc_conv_variable (se, expr);
1918 se->expr = null_pointer_node;
1921 case EXPR_SUBSTRING:
1922 gfc_conv_substring_expr (se, expr);
1925 case EXPR_STRUCTURE:
1926 gfc_conv_structure (se, expr, 0);
1930 gfc_conv_array_constructor_expr (se, expr);
1940 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1942 gfc_conv_expr (se, expr);
1943 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1944 figure out a way of rewriting an lvalue so that it has no post chain. */
1945 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1949 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1953 gcc_assert (expr->ts.type != BT_CHARACTER);
1954 gfc_conv_expr (se, expr);
1957 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1958 gfc_add_modify_expr (&se->pre, val, se->expr);
1963 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1965 gfc_conv_expr_val (se, expr);
1966 se->expr = convert (type, se->expr);
1970 /* Converts an expression so that it can be passed by reference. Scalar
1974 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1978 if (se->ss && se->ss->expr == expr
1979 && se->ss->type == GFC_SS_REFERENCE)
1981 se->expr = se->ss->data.scalar.expr;
1982 se->string_length = se->ss->string_length;
1983 gfc_advance_se_ss_chain (se);
1987 if (expr->ts.type == BT_CHARACTER)
1989 gfc_conv_expr (se, expr);
1990 gfc_conv_string_parameter (se);
1994 if (expr->expr_type == EXPR_VARIABLE)
1996 se->want_pointer = 1;
1997 gfc_conv_expr (se, expr);
2000 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2001 gfc_add_modify_expr (&se->pre, var, se->expr);
2002 gfc_add_block_to_block (&se->pre, &se->post);
2008 gfc_conv_expr (se, expr);
2010 /* Create a temporary var to hold the value. */
2011 if (TREE_CONSTANT (se->expr))
2013 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2014 DECL_INITIAL (var) = se->expr;
2019 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2020 gfc_add_modify_expr (&se->pre, var, se->expr);
2022 gfc_add_block_to_block (&se->pre, &se->post);
2024 /* Take the address of that value. */
2025 se->expr = gfc_build_addr_expr (NULL, var);
2030 gfc_trans_pointer_assign (gfc_code * code)
2032 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2036 /* Generate code for a pointer assignment. */
2039 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2047 gfc_start_block (&block);
2049 gfc_init_se (&lse, NULL);
2051 lss = gfc_walk_expr (expr1);
2052 rss = gfc_walk_expr (expr2);
2053 if (lss == gfc_ss_terminator)
2055 /* Scalar pointers. */
2056 lse.want_pointer = 1;
2057 gfc_conv_expr (&lse, expr1);
2058 gcc_assert (rss == gfc_ss_terminator);
2059 gfc_init_se (&rse, NULL);
2060 rse.want_pointer = 1;
2061 gfc_conv_expr (&rse, expr2);
2062 gfc_add_block_to_block (&block, &lse.pre);
2063 gfc_add_block_to_block (&block, &rse.pre);
2064 gfc_add_modify_expr (&block, lse.expr,
2065 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2066 gfc_add_block_to_block (&block, &rse.post);
2067 gfc_add_block_to_block (&block, &lse.post);
2071 /* Array pointer. */
2072 gfc_conv_expr_descriptor (&lse, expr1, lss);
2073 /* Implement Nullify. */
2074 if (expr2->expr_type == EXPR_NULL)
2075 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2078 lse.direct_byref = 1;
2079 gfc_conv_expr_descriptor (&lse, expr2, rss);
2081 gfc_add_block_to_block (&block, &lse.pre);
2082 gfc_add_block_to_block (&block, &lse.post);
2084 return gfc_finish_block (&block);
2088 /* Makes sure se is suitable for passing as a function string parameter. */
2089 /* TODO: Need to check all callers fo this function. It may be abused. */
2092 gfc_conv_string_parameter (gfc_se * se)
2096 if (TREE_CODE (se->expr) == STRING_CST)
2098 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2102 type = TREE_TYPE (se->expr);
2103 if (TYPE_STRING_FLAG (type))
2105 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2106 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2109 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2110 gcc_assert (se->string_length
2111 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2115 /* Generate code for assignment of scalar variables. Includes character
2119 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2123 gfc_init_block (&block);
2125 if (type == BT_CHARACTER)
2127 gcc_assert (lse->string_length != NULL_TREE
2128 && rse->string_length != NULL_TREE);
2130 gfc_conv_string_parameter (lse);
2131 gfc_conv_string_parameter (rse);
2133 gfc_add_block_to_block (&block, &lse->pre);
2134 gfc_add_block_to_block (&block, &rse->pre);
2136 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2137 rse->string_length, rse->expr);
2141 gfc_add_block_to_block (&block, &lse->pre);
2142 gfc_add_block_to_block (&block, &rse->pre);
2144 gfc_add_modify_expr (&block, lse->expr,
2145 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2148 gfc_add_block_to_block (&block, &lse->post);
2149 gfc_add_block_to_block (&block, &rse->post);
2151 return gfc_finish_block (&block);
2155 /* Try to translate array(:) = func (...), where func is a transformational
2156 array function, without using a temporary. Returns NULL is this isn't the
2160 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2165 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2166 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2169 /* Elemental functions don't need a temporary anyway. */
2170 if (expr2->symtree->n.sym->attr.elemental)
2173 /* Check for a dependency. */
2174 if (gfc_check_fncall_dependency (expr1, expr2))
2177 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2179 gcc_assert (expr2->value.function.isym
2180 || (gfc_return_by_reference (expr2->value.function.esym)
2181 && expr2->value.function.esym->result->attr.dimension));
2183 ss = gfc_walk_expr (expr1);
2184 gcc_assert (ss != gfc_ss_terminator);
2185 gfc_init_se (&se, NULL);
2186 gfc_start_block (&se.pre);
2187 se.want_pointer = 1;
2189 gfc_conv_array_parameter (&se, expr1, ss, 0);
2191 se.direct_byref = 1;
2192 se.ss = gfc_walk_expr (expr2);
2193 gcc_assert (se.ss != gfc_ss_terminator);
2194 gfc_conv_function_expr (&se, expr2);
2195 gfc_add_block_to_block (&se.pre, &se.post);
2197 return gfc_finish_block (&se.pre);
2201 /* Translate an assignment. Most of the code is concerned with
2202 setting up the scalarizer. */
2205 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2210 gfc_ss *lss_section;
2217 /* Special case a single function returning an array. */
2218 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2220 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2225 /* Assignment of the form lhs = rhs. */
2226 gfc_start_block (&block);
2228 gfc_init_se (&lse, NULL);
2229 gfc_init_se (&rse, NULL);
2232 lss = gfc_walk_expr (expr1);
2234 if (lss != gfc_ss_terminator)
2236 /* The assignment needs scalarization. */
2239 /* Find a non-scalar SS from the lhs. */
2240 while (lss_section != gfc_ss_terminator
2241 && lss_section->type != GFC_SS_SECTION)
2242 lss_section = lss_section->next;
2244 gcc_assert (lss_section != gfc_ss_terminator);
2246 /* Initialize the scalarizer. */
2247 gfc_init_loopinfo (&loop);
2250 rss = gfc_walk_expr (expr2);
2251 if (rss == gfc_ss_terminator)
2253 /* The rhs is scalar. Add a ss for the expression. */
2254 rss = gfc_get_ss ();
2255 rss->next = gfc_ss_terminator;
2256 rss->type = GFC_SS_SCALAR;
2259 /* Associate the SS with the loop. */
2260 gfc_add_ss_to_loop (&loop, lss);
2261 gfc_add_ss_to_loop (&loop, rss);
2263 /* Calculate the bounds of the scalarization. */
2264 gfc_conv_ss_startstride (&loop);
2265 /* Resolve any data dependencies in the statement. */
2266 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2267 /* Setup the scalarizing loops. */
2268 gfc_conv_loop_setup (&loop);
2270 /* Setup the gfc_se structures. */
2271 gfc_copy_loopinfo_to_se (&lse, &loop);
2272 gfc_copy_loopinfo_to_se (&rse, &loop);
2275 gfc_mark_ss_chain_used (rss, 1);
2276 if (loop.temp_ss == NULL)
2279 gfc_mark_ss_chain_used (lss, 1);
2283 lse.ss = loop.temp_ss;
2284 gfc_mark_ss_chain_used (lss, 3);
2285 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2288 /* Start the scalarized loop body. */
2289 gfc_start_scalarized_body (&loop, &body);
2292 gfc_init_block (&body);
2294 /* Translate the expression. */
2295 gfc_conv_expr (&rse, expr2);
2297 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2299 gfc_conv_tmp_array_ref (&lse);
2300 gfc_advance_se_ss_chain (&lse);
2303 gfc_conv_expr (&lse, expr1);
2305 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2306 gfc_add_expr_to_block (&body, tmp);
2308 if (lss == gfc_ss_terminator)
2310 /* Use the scalar assignment as is. */
2311 gfc_add_block_to_block (&block, &body);
2315 gcc_assert (lse.ss == gfc_ss_terminator
2316 && rse.ss == gfc_ss_terminator);
2318 if (loop.temp_ss != NULL)
2320 gfc_trans_scalarized_loop_boundary (&loop, &body);
2322 /* We need to copy the temporary to the actual lhs. */
2323 gfc_init_se (&lse, NULL);
2324 gfc_init_se (&rse, NULL);
2325 gfc_copy_loopinfo_to_se (&lse, &loop);
2326 gfc_copy_loopinfo_to_se (&rse, &loop);
2328 rse.ss = loop.temp_ss;
2331 gfc_conv_tmp_array_ref (&rse);
2332 gfc_advance_se_ss_chain (&rse);
2333 gfc_conv_expr (&lse, expr1);
2335 gcc_assert (lse.ss == gfc_ss_terminator
2336 && rse.ss == gfc_ss_terminator);
2338 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2339 gfc_add_expr_to_block (&body, tmp);
2341 /* Generate the copying loops. */
2342 gfc_trans_scalarizing_loops (&loop, &body);
2344 /* Wrap the whole thing up. */
2345 gfc_add_block_to_block (&block, &loop.pre);
2346 gfc_add_block_to_block (&block, &loop.post);
2348 gfc_cleanup_loop (&loop);
2351 return gfc_finish_block (&block);
2355 gfc_trans_assign (gfc_code * code)
2357 return gfc_trans_assignment (code->expr, code->expr2);