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)
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. */
1079 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1080 gfc_actual_arglist * arg)
1093 gfc_formal_arglist *formal;
1095 arglist = NULL_TREE;
1096 stringargs = NULL_TREE;
1100 /* Obtain the string length now because it is needed often below. */
1101 if (sym->ts.type == BT_CHARACTER)
1103 gcc_assert (sym->ts.cl && sym->ts.cl->length
1104 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1105 len = gfc_conv_mpz_to_tree
1106 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1111 if (!sym->attr.elemental)
1113 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1114 if (se->ss->useflags)
1116 gcc_assert (gfc_return_by_reference (sym)
1117 && sym->result->attr.dimension);
1118 gcc_assert (se->loop != NULL);
1120 /* Access the previously obtained result. */
1121 gfc_conv_tmp_array_ref (se);
1122 gfc_advance_se_ss_chain (se);
1124 /* Bundle in the string length. */
1125 se->string_length = len;
1129 info = &se->ss->data.info;
1134 byref = gfc_return_by_reference (sym);
1137 if (se->direct_byref)
1139 arglist = gfc_chainon_list (arglist, se->expr);
1141 /* Add string length to argument list. */
1142 if (sym->ts.type == BT_CHARACTER)
1144 sym->ts.cl->backend_decl = len;
1145 arglist = gfc_chainon_list (arglist,
1146 convert (gfc_charlen_type_node, len));
1149 else if (sym->result->attr.dimension)
1151 gcc_assert (se->loop && se->ss);
1153 /* Set the type of the array. */
1154 tmp = gfc_typenode_for_spec (&sym->ts);
1155 info->dimen = se->loop->dimen;
1157 /* Allocate a temporary to store the result. */
1158 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1160 /* Zero the first stride to indicate a temporary. */
1162 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1163 gfc_add_modify_expr (&se->pre, tmp,
1164 convert (TREE_TYPE (tmp), integer_zero_node));
1166 /* Pass the temporary as the first argument. */
1167 tmp = info->descriptor;
1168 tmp = gfc_build_addr_expr (NULL, tmp);
1169 arglist = gfc_chainon_list (arglist, tmp);
1171 /* Add string length to argument list. */
1172 if (sym->ts.type == BT_CHARACTER)
1174 sym->ts.cl->backend_decl = len;
1175 arglist = gfc_chainon_list (arglist,
1176 convert (gfc_charlen_type_node, len));
1180 else if (sym->ts.type == BT_CHARACTER)
1183 /* Pass the string length. */
1184 sym->ts.cl->backend_decl = len;
1185 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1186 type = build_pointer_type (type);
1188 /* Return an address to a char[0:len-1]* temporary for character pointers. */
1189 if (sym->attr.pointer || sym->attr.allocatable)
1191 /* Build char[0:len-1] * pstr. */
1192 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1193 build_int_cst (gfc_charlen_type_node, 1));
1194 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1195 tmp = build_array_type (gfc_character1_type_node, tmp);
1196 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1198 /* Provide an address expression for the function arguments. */
1199 var = gfc_build_addr_expr (NULL, var);
1203 var = gfc_conv_string_tmp (se, type, len);
1205 arglist = gfc_chainon_list (arglist, var);
1206 arglist = gfc_chainon_list (arglist,
1207 convert (gfc_charlen_type_node, len));
1211 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1213 type = gfc_get_complex_type (sym->ts.kind);
1214 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1215 arglist = gfc_chainon_list (arglist, var);
1219 formal = sym->formal;
1220 /* Evaluate the arguments. */
1221 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1223 if (arg->expr == NULL)
1226 if (se->ignore_optional)
1228 /* Some intrinsics have already been resolved to the correct
1232 else if (arg->label)
1234 has_alternate_specifier = 1;
1239 /* Pass a NULL pointer for an absent arg. */
1240 gfc_init_se (&parmse, NULL);
1241 parmse.expr = null_pointer_node;
1242 if (arg->missing_arg_type == BT_CHARACTER)
1245 gfc_chainon_list (stringargs,
1246 convert (gfc_charlen_type_node,
1247 integer_zero_node));
1251 else if (se->ss && se->ss->useflags)
1253 /* An elemental function inside a scalarized loop. */
1254 gfc_init_se (&parmse, se);
1255 gfc_conv_expr_reference (&parmse, arg->expr);
1259 /* A scalar or transformational function. */
1260 gfc_init_se (&parmse, NULL);
1261 argss = gfc_walk_expr (arg->expr);
1263 if (argss == gfc_ss_terminator)
1265 gfc_conv_expr_reference (&parmse, arg->expr);
1266 if (formal && formal->sym->attr.pointer
1267 && arg->expr->expr_type != EXPR_NULL)
1269 /* Scalar pointer dummy args require an extra level of
1270 indirection. The null pointer already contains
1271 this level of indirection. */
1272 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1277 /* If the procedure requires an explicit interface, the
1278 actual argument is passed according to the
1279 corresponding formal argument. If the corresponding
1280 formal argument is a POINTER or assumed shape, we do
1281 not use g77's calling convention, and pass the
1282 address of the array descriptor instead. Otherwise we
1283 use g77's calling convention. */
1285 f = (formal != NULL)
1286 && !formal->sym->attr.pointer
1287 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1288 f = f || !sym->attr.always_explicit;
1289 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1293 gfc_add_block_to_block (&se->pre, &parmse.pre);
1294 gfc_add_block_to_block (&se->post, &parmse.post);
1296 /* Character strings are passed as two parameters, a length and a
1298 if (parmse.string_length != NULL_TREE)
1299 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1301 arglist = gfc_chainon_list (arglist, parmse.expr);
1304 /* Add the hidden string length parameters to the arguments. */
1305 arglist = chainon (arglist, stringargs);
1307 /* Generate the actual call. */
1308 gfc_conv_function_val (se, sym);
1309 /* If there are alternate return labels, function type should be
1311 if (has_alternate_specifier)
1312 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1314 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1315 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1316 arglist, NULL_TREE);
1321 /* If we have a pointer function, but we don't want a pointer, e.g.
1324 where f is pointer valued, we have to dereference the result. */
1325 if (!se->want_pointer && !byref && sym->attr.pointer)
1326 se->expr = gfc_build_indirect_ref (se->expr);
1328 /* f2c calling conventions require a scalar default real function to
1329 return a double precision result. Convert this back to default
1330 real. We only care about the cases that can happen in Fortran 77.
1332 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1333 && sym->ts.kind == gfc_default_real_kind
1334 && !sym->attr.always_explicit)
1335 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1337 /* A pure function may still have side-effects - it may modify its
1339 TREE_SIDE_EFFECTS (se->expr) = 1;
1341 if (!sym->attr.pure)
1342 TREE_SIDE_EFFECTS (se->expr) = 1;
1347 /* Add the function call to the pre chain. There is no expression. */
1348 gfc_add_expr_to_block (&se->pre, se->expr);
1349 se->expr = NULL_TREE;
1351 if (!se->direct_byref)
1353 if (sym->attr.dimension)
1355 if (flag_bounds_check)
1357 /* Check the data pointer hasn't been modified. This would
1358 happen in a function returning a pointer. */
1359 tmp = gfc_conv_descriptor_data (info->descriptor);
1360 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1361 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1363 se->expr = info->descriptor;
1364 /* Bundle in the string length. */
1365 se->string_length = len;
1367 else if (sym->ts.type == BT_CHARACTER)
1369 /* Dereference for character pointer results. */
1370 if (sym->attr.pointer || sym->attr.allocatable)
1371 se->expr = gfc_build_indirect_ref (var);
1375 se->string_length = len;
1379 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1380 se->expr = gfc_build_indirect_ref (var);
1387 /* Generate code to copy a string. */
1390 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1391 tree slen, tree src)
1396 tmp = gfc_chainon_list (tmp, dlen);
1397 tmp = gfc_chainon_list (tmp, dest);
1398 tmp = gfc_chainon_list (tmp, slen);
1399 tmp = gfc_chainon_list (tmp, src);
1400 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1401 gfc_add_expr_to_block (block, tmp);
1405 /* Translate a statement function.
1406 The value of a statement function reference is obtained by evaluating the
1407 expression using the values of the actual arguments for the values of the
1408 corresponding dummy arguments. */
1411 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1415 gfc_formal_arglist *fargs;
1416 gfc_actual_arglist *args;
1419 gfc_saved_var *saved_vars;
1425 sym = expr->symtree->n.sym;
1426 args = expr->value.function.actual;
1427 gfc_init_se (&lse, NULL);
1428 gfc_init_se (&rse, NULL);
1431 for (fargs = sym->formal; fargs; fargs = fargs->next)
1433 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1434 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1436 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1438 /* Each dummy shall be specified, explicitly or implicitly, to be
1440 gcc_assert (fargs->sym->attr.dimension == 0);
1443 /* Create a temporary to hold the value. */
1444 type = gfc_typenode_for_spec (&fsym->ts);
1445 temp_vars[n] = gfc_create_var (type, fsym->name);
1447 if (fsym->ts.type == BT_CHARACTER)
1449 /* Copy string arguments. */
1452 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1453 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1455 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1456 tmp = gfc_build_addr_expr (build_pointer_type (type),
1459 gfc_conv_expr (&rse, args->expr);
1460 gfc_conv_string_parameter (&rse);
1461 gfc_add_block_to_block (&se->pre, &lse.pre);
1462 gfc_add_block_to_block (&se->pre, &rse.pre);
1464 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1466 gfc_add_block_to_block (&se->pre, &lse.post);
1467 gfc_add_block_to_block (&se->pre, &rse.post);
1471 /* For everything else, just evaluate the expression. */
1472 gfc_conv_expr (&lse, args->expr);
1474 gfc_add_block_to_block (&se->pre, &lse.pre);
1475 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1476 gfc_add_block_to_block (&se->pre, &lse.post);
1482 /* Use the temporary variables in place of the real ones. */
1483 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1484 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1486 gfc_conv_expr (se, sym->value);
1488 if (sym->ts.type == BT_CHARACTER)
1490 gfc_conv_const_charlen (sym->ts.cl);
1492 /* Force the expression to the correct length. */
1493 if (!INTEGER_CST_P (se->string_length)
1494 || tree_int_cst_lt (se->string_length,
1495 sym->ts.cl->backend_decl))
1497 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1498 tmp = gfc_create_var (type, sym->name);
1499 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1500 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1501 se->string_length, se->expr);
1504 se->string_length = sym->ts.cl->backend_decl;
1507 /* Restore the original variables. */
1508 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1509 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1510 gfc_free (saved_vars);
1514 /* Translate a function expression. */
1517 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1521 if (expr->value.function.isym)
1523 gfc_conv_intrinsic_function (se, expr);
1527 /* We distinguish statement functions from general functions to improve
1528 runtime performance. */
1529 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1531 gfc_conv_statement_function (se, expr);
1535 /* expr.value.function.esym is the resolved (specific) function symbol for
1536 most functions. However this isn't set for dummy procedures. */
1537 sym = expr->value.function.esym;
1539 sym = expr->symtree->n.sym;
1540 gfc_conv_function_call (se, sym, expr->value.function.actual);
1545 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1547 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1548 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1550 gfc_conv_tmp_array_ref (se);
1551 gfc_advance_se_ss_chain (se);
1555 /* Build a static initializer. EXPR is the expression for the initial value.
1556 The other parameters describe the variable of the component being
1557 initialized. EXPR may be null. */
1560 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1561 bool array, bool pointer)
1565 if (!(expr || pointer))
1570 /* Arrays need special handling. */
1572 return gfc_build_null_descriptor (type);
1574 return gfc_conv_array_initializer (type, expr);
1577 return fold_convert (type, null_pointer_node);
1583 gfc_init_se (&se, NULL);
1584 gfc_conv_structure (&se, expr, 1);
1588 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1591 gfc_init_se (&se, NULL);
1592 gfc_conv_constant (&se, expr);
1599 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1611 gfc_start_block (&block);
1613 /* Initialize the scalarizer. */
1614 gfc_init_loopinfo (&loop);
1616 gfc_init_se (&lse, NULL);
1617 gfc_init_se (&rse, NULL);
1620 rss = gfc_walk_expr (expr);
1621 if (rss == gfc_ss_terminator)
1623 /* The rhs is scalar. Add a ss for the expression. */
1624 rss = gfc_get_ss ();
1625 rss->next = gfc_ss_terminator;
1626 rss->type = GFC_SS_SCALAR;
1630 /* Create a SS for the destination. */
1631 lss = gfc_get_ss ();
1632 lss->type = GFC_SS_COMPONENT;
1634 lss->shape = gfc_get_shape (cm->as->rank);
1635 lss->next = gfc_ss_terminator;
1636 lss->data.info.dimen = cm->as->rank;
1637 lss->data.info.descriptor = dest;
1638 lss->data.info.data = gfc_conv_array_data (dest);
1639 lss->data.info.offset = gfc_conv_array_offset (dest);
1640 for (n = 0; n < cm->as->rank; n++)
1642 lss->data.info.dim[n] = n;
1643 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1644 lss->data.info.stride[n] = gfc_index_one_node;
1646 mpz_init (lss->shape[n]);
1647 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1648 cm->as->lower[n]->value.integer);
1649 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1652 /* Associate the SS with the loop. */
1653 gfc_add_ss_to_loop (&loop, lss);
1654 gfc_add_ss_to_loop (&loop, rss);
1656 /* Calculate the bounds of the scalarization. */
1657 gfc_conv_ss_startstride (&loop);
1659 /* Setup the scalarizing loops. */
1660 gfc_conv_loop_setup (&loop);
1662 /* Setup the gfc_se structures. */
1663 gfc_copy_loopinfo_to_se (&lse, &loop);
1664 gfc_copy_loopinfo_to_se (&rse, &loop);
1667 gfc_mark_ss_chain_used (rss, 1);
1669 gfc_mark_ss_chain_used (lss, 1);
1671 /* Start the scalarized loop body. */
1672 gfc_start_scalarized_body (&loop, &body);
1674 gfc_conv_tmp_array_ref (&lse);
1675 if (cm->ts.type == BT_CHARACTER)
1676 lse.string_length = cm->ts.cl->backend_decl;
1678 gfc_conv_expr (&rse, expr);
1680 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1681 gfc_add_expr_to_block (&body, tmp);
1683 gcc_assert (rse.ss == gfc_ss_terminator);
1685 /* Generate the copying loops. */
1686 gfc_trans_scalarizing_loops (&loop, &body);
1688 /* Wrap the whole thing up. */
1689 gfc_add_block_to_block (&block, &loop.pre);
1690 gfc_add_block_to_block (&block, &loop.post);
1692 for (n = 0; n < cm->as->rank; n++)
1693 mpz_clear (lss->shape[n]);
1694 gfc_free (lss->shape);
1696 gfc_cleanup_loop (&loop);
1698 return gfc_finish_block (&block);
1701 /* Assign a single component of a derived type constructor. */
1704 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1711 gfc_start_block (&block);
1714 gfc_init_se (&se, NULL);
1715 /* Pointer component. */
1718 /* Array pointer. */
1719 if (expr->expr_type == EXPR_NULL)
1721 dest = gfc_conv_descriptor_data (dest);
1722 tmp = fold_convert (TREE_TYPE (se.expr),
1724 gfc_add_modify_expr (&block, dest, tmp);
1728 rss = gfc_walk_expr (expr);
1729 se.direct_byref = 1;
1731 gfc_conv_expr_descriptor (&se, expr, rss);
1732 gfc_add_block_to_block (&block, &se.pre);
1733 gfc_add_block_to_block (&block, &se.post);
1738 /* Scalar pointers. */
1739 se.want_pointer = 1;
1740 gfc_conv_expr (&se, expr);
1741 gfc_add_block_to_block (&block, &se.pre);
1742 gfc_add_modify_expr (&block, dest,
1743 fold_convert (TREE_TYPE (dest), se.expr));
1744 gfc_add_block_to_block (&block, &se.post);
1747 else if (cm->dimension)
1749 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1750 gfc_add_expr_to_block (&block, tmp);
1752 else if (expr->ts.type == BT_DERIVED)
1754 /* Nested derived type. */
1755 tmp = gfc_trans_structure_assign (dest, expr);
1756 gfc_add_expr_to_block (&block, tmp);
1760 /* Scalar component. */
1763 gfc_init_se (&se, NULL);
1764 gfc_init_se (&lse, NULL);
1766 gfc_conv_expr (&se, expr);
1767 if (cm->ts.type == BT_CHARACTER)
1768 lse.string_length = cm->ts.cl->backend_decl;
1770 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1771 gfc_add_expr_to_block (&block, tmp);
1773 return gfc_finish_block (&block);
1776 /* Assign a derived type constructor to a variable. */
1779 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1787 gfc_start_block (&block);
1788 cm = expr->ts.derived->components;
1789 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1791 /* Skip absent members in default initializers. */
1795 field = cm->backend_decl;
1796 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1797 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1798 gfc_add_expr_to_block (&block, tmp);
1800 return gfc_finish_block (&block);
1803 /* Build an expression for a constructor. If init is nonzero then
1804 this is part of a static variable initializer. */
1807 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1817 gcc_assert (se->ss == NULL);
1818 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1819 type = gfc_typenode_for_spec (&expr->ts);
1823 /* Create a temporary variable and fill it in. */
1824 se->expr = gfc_create_var (type, expr->ts.derived->name);
1825 tmp = gfc_trans_structure_assign (se->expr, expr);
1826 gfc_add_expr_to_block (&se->pre, tmp);
1830 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1833 cm = expr->ts.derived->components;
1834 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1836 /* Skip absent members in default initializers. */
1840 val = gfc_conv_initializer (c->expr, &cm->ts,
1841 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1843 /* Build a TREE_CHAIN to hold it. */
1844 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1846 /* Add it to the list. */
1847 if (tail == NULL_TREE)
1848 TREE_OPERAND(head, 0) = tail = val;
1851 TREE_CHAIN (tail) = val;
1859 /* Translate a substring expression. */
1862 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1868 gcc_assert (ref->type == REF_SUBSTRING);
1870 se->expr = gfc_build_string_const(expr->value.character.length,
1871 expr->value.character.string);
1872 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1873 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1875 gfc_conv_substring(se,ref,expr->ts.kind);
1879 /* Entry point for expression translation. */
1882 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1884 if (se->ss && se->ss->expr == expr
1885 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1887 /* Substitute a scalar expression evaluated outside the scalarization
1889 se->expr = se->ss->data.scalar.expr;
1890 se->string_length = se->ss->string_length;
1891 gfc_advance_se_ss_chain (se);
1895 switch (expr->expr_type)
1898 gfc_conv_expr_op (se, expr);
1902 gfc_conv_function_expr (se, expr);
1906 gfc_conv_constant (se, expr);
1910 gfc_conv_variable (se, expr);
1914 se->expr = null_pointer_node;
1917 case EXPR_SUBSTRING:
1918 gfc_conv_substring_expr (se, expr);
1921 case EXPR_STRUCTURE:
1922 gfc_conv_structure (se, expr, 0);
1926 gfc_conv_array_constructor_expr (se, expr);
1936 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1938 gfc_conv_expr (se, expr);
1939 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1940 figure out a way of rewriting an lvalue so that it has no post chain. */
1941 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1945 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1949 gcc_assert (expr->ts.type != BT_CHARACTER);
1950 gfc_conv_expr (se, expr);
1953 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1954 gfc_add_modify_expr (&se->pre, val, se->expr);
1959 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1961 gfc_conv_expr_val (se, expr);
1962 se->expr = convert (type, se->expr);
1966 /* Converts an expression so that it can be passed by reference. Scalar
1970 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1974 if (se->ss && se->ss->expr == expr
1975 && se->ss->type == GFC_SS_REFERENCE)
1977 se->expr = se->ss->data.scalar.expr;
1978 se->string_length = se->ss->string_length;
1979 gfc_advance_se_ss_chain (se);
1983 if (expr->ts.type == BT_CHARACTER)
1985 gfc_conv_expr (se, expr);
1986 gfc_conv_string_parameter (se);
1990 if (expr->expr_type == EXPR_VARIABLE)
1992 se->want_pointer = 1;
1993 gfc_conv_expr (se, expr);
1996 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1997 gfc_add_modify_expr (&se->pre, var, se->expr);
1998 gfc_add_block_to_block (&se->pre, &se->post);
2004 gfc_conv_expr (se, expr);
2006 /* Create a temporary var to hold the value. */
2007 if (TREE_CONSTANT (se->expr))
2009 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2010 DECL_INITIAL (var) = se->expr;
2015 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2016 gfc_add_modify_expr (&se->pre, var, se->expr);
2018 gfc_add_block_to_block (&se->pre, &se->post);
2020 /* Take the address of that value. */
2021 se->expr = gfc_build_addr_expr (NULL, var);
2026 gfc_trans_pointer_assign (gfc_code * code)
2028 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2032 /* Generate code for a pointer assignment. */
2035 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2043 gfc_start_block (&block);
2045 gfc_init_se (&lse, NULL);
2047 lss = gfc_walk_expr (expr1);
2048 rss = gfc_walk_expr (expr2);
2049 if (lss == gfc_ss_terminator)
2051 /* Scalar pointers. */
2052 lse.want_pointer = 1;
2053 gfc_conv_expr (&lse, expr1);
2054 gcc_assert (rss == gfc_ss_terminator);
2055 gfc_init_se (&rse, NULL);
2056 rse.want_pointer = 1;
2057 gfc_conv_expr (&rse, expr2);
2058 gfc_add_block_to_block (&block, &lse.pre);
2059 gfc_add_block_to_block (&block, &rse.pre);
2060 gfc_add_modify_expr (&block, lse.expr,
2061 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2062 gfc_add_block_to_block (&block, &rse.post);
2063 gfc_add_block_to_block (&block, &lse.post);
2067 /* Array pointer. */
2068 gfc_conv_expr_descriptor (&lse, expr1, lss);
2069 /* Implement Nullify. */
2070 if (expr2->expr_type == EXPR_NULL)
2072 lse.expr = gfc_conv_descriptor_data (lse.expr);
2073 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
2074 gfc_add_modify_expr (&block, lse.expr, rse.expr);
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);