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)
368 && ((sym->attr.dummy)
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)
388 && ((sym->attr.dummy)
389 || (sym->attr.function || sym->attr.result)
390 || (!sym->attr.dimension)))
391 se->expr = gfc_build_indirect_ref (se->expr);
397 /* For character variables, also get the length. */
398 if (sym->ts.type == BT_CHARACTER)
400 se->string_length = sym->ts.cl->backend_decl;
401 gcc_assert (se->string_length);
409 /* Return the descriptor if that's what we want and this is an array
410 section reference. */
411 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
413 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
414 /* Return the descriptor for array pointers and allocations. */
416 && ref->next == NULL && (se->descriptor_only))
419 gfc_conv_array_ref (se, &ref->u.ar);
420 /* Return a pointer to an element. */
424 gfc_conv_component_ref (se, ref);
428 gfc_conv_substring (se, ref, expr->ts.kind);
437 /* Pointer assignment, allocation or pass by reference. Arrays are handled
439 if (se->want_pointer)
441 if (expr->ts.type == BT_CHARACTER)
442 gfc_conv_string_parameter (se);
444 se->expr = gfc_build_addr_expr (NULL, se->expr);
447 gfc_advance_se_ss_chain (se);
451 /* Unary ops are easy... Or they would be if ! was a valid op. */
454 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
459 gcc_assert (expr->ts.type != BT_CHARACTER);
460 /* Initialize the operand. */
461 gfc_init_se (&operand, se);
462 gfc_conv_expr_val (&operand, expr->value.op.op1);
463 gfc_add_block_to_block (&se->pre, &operand.pre);
465 type = gfc_typenode_for_spec (&expr->ts);
467 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
468 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
469 All other unary operators have an equivalent GIMPLE unary operator. */
470 if (code == TRUTH_NOT_EXPR)
471 se->expr = build2 (EQ_EXPR, type, operand.expr,
472 convert (type, integer_zero_node));
474 se->expr = build1 (code, type, operand.expr);
478 /* Expand power operator to optimal multiplications when a value is raised
479 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
480 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
481 Programming", 3rd Edition, 1998. */
483 /* This code is mostly duplicated from expand_powi in the backend.
484 We establish the "optimal power tree" lookup table with the defined size.
485 The items in the table are the exponents used to calculate the index
486 exponents. Any integer n less than the value can get an "addition chain",
487 with the first node being one. */
488 #define POWI_TABLE_SIZE 256
490 /* The table is from builtins.c. */
491 static const unsigned char powi_table[POWI_TABLE_SIZE] =
493 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
494 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
495 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
496 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
497 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
498 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
499 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
500 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
501 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
502 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
503 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
504 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
505 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
506 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
507 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
508 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
509 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
510 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
511 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
512 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
513 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
514 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
515 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
516 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
517 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
518 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
519 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
520 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
521 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
522 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
523 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
524 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
527 /* If n is larger than lookup table's max index, we use the "window
529 #define POWI_WINDOW_SIZE 3
531 /* Recursive function to expand the power operator. The temporary
532 values are put in tmpvar. The function returns tmpvar[1] ** n. */
534 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
541 if (n < POWI_TABLE_SIZE)
546 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
547 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
551 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
552 op0 = gfc_conv_powi (se, n - digit, tmpvar);
553 op1 = gfc_conv_powi (se, digit, tmpvar);
557 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
561 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
562 tmp = gfc_evaluate_now (tmp, &se->pre);
564 if (n < POWI_TABLE_SIZE)
571 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
572 return 1. Else return 0 and a call to runtime library functions
573 will have to be built. */
575 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
580 tree vartmp[POWI_TABLE_SIZE];
584 type = TREE_TYPE (lhs);
585 n = abs (TREE_INT_CST_LOW (rhs));
586 sgn = tree_int_cst_sgn (rhs);
588 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
589 && (n > 2 || n < -1))
595 se->expr = gfc_build_const (type, integer_one_node);
598 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
599 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
601 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
602 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
603 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
604 convert (TREE_TYPE (lhs), integer_one_node));
607 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
610 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
611 se->expr = build3 (COND_EXPR, type, tmp,
612 convert (type, integer_one_node),
613 convert (type, integer_zero_node));
617 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
618 tmp = build3 (COND_EXPR, type, tmp,
619 convert (type, integer_minus_one_node),
620 convert (type, integer_zero_node));
621 se->expr = build3 (COND_EXPR, type, cond,
622 convert (type, integer_one_node),
627 memset (vartmp, 0, sizeof (vartmp));
631 tmp = gfc_build_const (type, integer_one_node);
632 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
635 se->expr = gfc_conv_powi (se, n, vartmp);
641 /* Power op (**). Constant integer exponent has special handling. */
644 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
646 tree gfc_int4_type_node;
654 gfc_init_se (&lse, se);
655 gfc_conv_expr_val (&lse, expr->value.op.op1);
656 gfc_add_block_to_block (&se->pre, &lse.pre);
658 gfc_init_se (&rse, se);
659 gfc_conv_expr_val (&rse, expr->value.op.op2);
660 gfc_add_block_to_block (&se->pre, &rse.pre);
662 if (expr->value.op.op2->ts.type == BT_INTEGER
663 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
664 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
667 gfc_int4_type_node = gfc_get_int_type (4);
669 kind = expr->value.op.op1->ts.kind;
670 switch (expr->value.op.op2->ts.type)
673 ikind = expr->value.op.op2->ts.kind;
678 rse.expr = convert (gfc_int4_type_node, rse.expr);
696 if (expr->value.op.op1->ts.type == BT_INTEGER)
697 lse.expr = convert (gfc_int4_type_node, lse.expr);
714 switch (expr->value.op.op1->ts.type)
717 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
721 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
725 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
737 fndecl = built_in_decls[BUILT_IN_POWF];
740 fndecl = built_in_decls[BUILT_IN_POW];
751 fndecl = gfor_fndecl_math_cpowf;
754 fndecl = gfor_fndecl_math_cpow;
766 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
767 tmp = gfc_chainon_list (tmp, rse.expr);
768 se->expr = fold (gfc_build_function_call (fndecl, tmp));
772 /* Generate code to allocate a string temporary. */
775 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
781 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
783 if (gfc_can_put_var_on_stack (len))
785 /* Create a temporary variable to hold the result. */
786 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
787 convert (gfc_charlen_type_node, integer_one_node));
788 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
789 tmp = build_array_type (gfc_character1_type_node, tmp);
790 var = gfc_create_var (tmp, "str");
791 var = gfc_build_addr_expr (type, var);
795 /* Allocate a temporary to hold the result. */
796 var = gfc_create_var (type, "pstr");
797 args = gfc_chainon_list (NULL_TREE, len);
798 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
799 tmp = convert (type, tmp);
800 gfc_add_modify_expr (&se->pre, var, tmp);
802 /* Free the temporary afterwards. */
803 tmp = convert (pvoid_type_node, var);
804 args = gfc_chainon_list (NULL_TREE, tmp);
805 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
806 gfc_add_expr_to_block (&se->post, tmp);
813 /* Handle a string concatenation operation. A temporary will be allocated to
817 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
827 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
828 && expr->value.op.op2->ts.type == BT_CHARACTER);
830 gfc_init_se (&lse, se);
831 gfc_conv_expr (&lse, expr->value.op.op1);
832 gfc_conv_string_parameter (&lse);
833 gfc_init_se (&rse, se);
834 gfc_conv_expr (&rse, expr->value.op.op2);
835 gfc_conv_string_parameter (&rse);
837 gfc_add_block_to_block (&se->pre, &lse.pre);
838 gfc_add_block_to_block (&se->pre, &rse.pre);
840 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
841 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
842 if (len == NULL_TREE)
844 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
845 lse.string_length, rse.string_length);
848 type = build_pointer_type (type);
850 var = gfc_conv_string_tmp (se, type, len);
852 /* Do the actual concatenation. */
854 args = gfc_chainon_list (args, len);
855 args = gfc_chainon_list (args, var);
856 args = gfc_chainon_list (args, lse.string_length);
857 args = gfc_chainon_list (args, lse.expr);
858 args = gfc_chainon_list (args, rse.string_length);
859 args = gfc_chainon_list (args, rse.expr);
860 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
861 gfc_add_expr_to_block (&se->pre, tmp);
863 /* Add the cleanup for the operands. */
864 gfc_add_block_to_block (&se->pre, &rse.post);
865 gfc_add_block_to_block (&se->pre, &lse.post);
868 se->string_length = len;
872 /* Translates an op expression. Common (binary) cases are handled by this
873 function, others are passed on. Recursion is used in either case.
874 We use the fact that (op1.ts == op2.ts) (except for the power
876 Operators need no special handling for scalarized expressions as long as
877 they call gfc_conv_simple_val to get their operands.
878 Character strings get special handling. */
881 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
893 switch (expr->value.op.operator)
895 case INTRINSIC_UPLUS:
896 gfc_conv_expr (se, expr->value.op.op1);
899 case INTRINSIC_UMINUS:
900 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
904 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
911 case INTRINSIC_MINUS:
915 case INTRINSIC_TIMES:
919 case INTRINSIC_DIVIDE:
920 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
921 an integer, we must round towards zero, so we use a
923 if (expr->ts.type == BT_INTEGER)
924 code = TRUNC_DIV_EXPR;
929 case INTRINSIC_POWER:
930 gfc_conv_power_op (se, expr);
933 case INTRINSIC_CONCAT:
934 gfc_conv_concat_op (se, expr);
938 code = TRUTH_ANDIF_EXPR;
943 code = TRUTH_ORIF_EXPR;
947 /* EQV and NEQV only work on logicals, but since we represent them
948 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
988 case INTRINSIC_ASSIGN:
989 /* These should be converted into function calls by the frontend. */
993 fatal_error ("Unknown intrinsic op");
997 /* The only exception to this is **, which is handled separately anyway. */
998 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1000 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1004 gfc_init_se (&lse, se);
1005 gfc_conv_expr (&lse, expr->value.op.op1);
1006 gfc_add_block_to_block (&se->pre, &lse.pre);
1009 gfc_init_se (&rse, se);
1010 gfc_conv_expr (&rse, expr->value.op.op2);
1011 gfc_add_block_to_block (&se->pre, &rse.pre);
1013 /* For string comparisons we generate a library call, and compare the return
1017 gfc_conv_string_parameter (&lse);
1018 gfc_conv_string_parameter (&rse);
1020 tmp = gfc_chainon_list (tmp, lse.string_length);
1021 tmp = gfc_chainon_list (tmp, lse.expr);
1022 tmp = gfc_chainon_list (tmp, rse.string_length);
1023 tmp = gfc_chainon_list (tmp, rse.expr);
1025 /* Build a call for the comparison. */
1026 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1027 gfc_add_block_to_block (&lse.post, &rse.post);
1029 rse.expr = integer_zero_node;
1032 type = gfc_typenode_for_spec (&expr->ts);
1036 /* The result of logical ops is always boolean_type_node. */
1037 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1038 se->expr = convert (type, tmp);
1041 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1043 /* Add the post blocks. */
1044 gfc_add_block_to_block (&se->post, &rse.post);
1045 gfc_add_block_to_block (&se->post, &lse.post);
1050 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1054 if (sym->attr.dummy)
1056 tmp = gfc_get_symbol_decl (sym);
1057 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1058 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1064 if (!sym->backend_decl)
1065 sym->backend_decl = gfc_get_extern_function_decl (sym);
1067 tmp = sym->backend_decl;
1068 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1069 se->expr = gfc_build_addr_expr (NULL, tmp);
1074 /* Generate code for a procedure call. Note can return se->post != NULL.
1075 If se->direct_byref is set then se->expr contains the return parameter. */
1078 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1079 gfc_actual_arglist * arg)
1092 gfc_formal_arglist *formal;
1094 arglist = NULL_TREE;
1095 stringargs = NULL_TREE;
1099 /* Obtain the string length now because it is needed often below. */
1100 if (sym->ts.type == BT_CHARACTER)
1102 gcc_assert (sym->ts.cl && sym->ts.cl->length
1103 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1104 len = gfc_conv_mpz_to_tree
1105 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1110 if (!sym->attr.elemental)
1112 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1113 if (se->ss->useflags)
1115 gcc_assert (gfc_return_by_reference (sym)
1116 && sym->result->attr.dimension);
1117 gcc_assert (se->loop != NULL);
1119 /* Access the previously obtained result. */
1120 gfc_conv_tmp_array_ref (se);
1121 gfc_advance_se_ss_chain (se);
1123 /* Bundle in the string length. */
1124 se->string_length=len;
1128 info = &se->ss->data.info;
1133 byref = gfc_return_by_reference (sym);
1136 if (se->direct_byref)
1138 arglist = gfc_chainon_list (arglist, se->expr);
1140 /* Add string length to argument list. */
1141 if (sym->ts.type == BT_CHARACTER)
1143 sym->ts.cl->backend_decl = len;
1144 arglist = gfc_chainon_list (arglist,
1145 convert (gfc_charlen_type_node, len));
1148 else if (sym->result->attr.dimension)
1150 gcc_assert (se->loop && se->ss);
1152 /* Set the type of the array. */
1153 tmp = gfc_typenode_for_spec (&sym->ts);
1154 info->dimen = se->loop->dimen;
1156 /* Allocate a temporary to store the result. */
1157 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1159 /* Zero the first stride to indicate a temporary. */
1161 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1162 gfc_add_modify_expr (&se->pre, tmp,
1163 convert (TREE_TYPE (tmp), integer_zero_node));
1165 /* Pass the temporary as the first argument. */
1166 tmp = info->descriptor;
1167 tmp = gfc_build_addr_expr (NULL, tmp);
1168 arglist = gfc_chainon_list (arglist, tmp);
1170 /* Add string length to argument list. */
1171 if (sym->ts.type == BT_CHARACTER)
1173 sym->ts.cl->backend_decl = len;
1174 arglist = gfc_chainon_list (arglist,
1175 convert (gfc_charlen_type_node, len));
1179 else if (sym->ts.type == BT_CHARACTER)
1182 /* Pass the string length. */
1183 sym->ts.cl->backend_decl = len;
1184 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1185 type = build_pointer_type (type);
1187 /* Return an address to a char[4]* temporary for character pointers. */
1188 if (sym->attr.pointer || sym->attr.allocatable)
1190 /* Build char[4] * pstr. */
1191 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1192 convert (gfc_charlen_type_node, integer_one_node));
1193 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1194 tmp = build_array_type (gfc_character1_type_node, tmp);
1195 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1197 /* Provide an address expression for the function arguments. */
1198 var = gfc_build_addr_expr (NULL, var);
1202 var = gfc_conv_string_tmp (se, type, len);
1204 arglist = gfc_chainon_list (arglist, var);
1205 arglist = gfc_chainon_list (arglist,
1206 convert (gfc_charlen_type_node, len));
1210 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1212 type = gfc_get_complex_type (sym->ts.kind);
1213 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1214 arglist = gfc_chainon_list (arglist, var);
1218 formal = sym->formal;
1219 /* Evaluate the arguments. */
1220 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1222 if (arg->expr == NULL)
1225 if (se->ignore_optional)
1227 /* Some intrinsics have already been resolved to the correct
1231 else if (arg->label)
1233 has_alternate_specifier = 1;
1238 /* Pass a NULL pointer for an absent arg. */
1239 gfc_init_se (&parmse, NULL);
1240 parmse.expr = null_pointer_node;
1241 if (arg->missing_arg_type == BT_CHARACTER)
1244 gfc_chainon_list (stringargs,
1245 convert (gfc_charlen_type_node,
1246 integer_zero_node));
1250 else if (se->ss && se->ss->useflags)
1252 /* An elemental function inside a scalarized loop. */
1253 gfc_init_se (&parmse, se);
1254 gfc_conv_expr_reference (&parmse, arg->expr);
1258 /* A scalar or transformational function. */
1259 gfc_init_se (&parmse, NULL);
1260 argss = gfc_walk_expr (arg->expr);
1262 if (argss == gfc_ss_terminator)
1264 gfc_conv_expr_reference (&parmse, arg->expr);
1265 if (formal && formal->sym->attr.pointer
1266 && arg->expr->expr_type != EXPR_NULL)
1268 /* Scalar pointer dummy args require an extra level of
1269 indirection. The null pointer already contains
1270 this level of indirection. */
1271 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1276 /* If the procedure requires an explicit interface, the
1277 actual argument is passed according to the
1278 corresponding formal argument. If the corresponding
1279 formal argument is a POINTER or assumed shape, we do
1280 not use g77's calling convention, and pass the
1281 address of the array descriptor instead. Otherwise we
1282 use g77's calling convention. */
1284 f = (formal != NULL)
1285 && !formal->sym->attr.pointer
1286 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1287 f = f || !sym->attr.always_explicit;
1288 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1292 gfc_add_block_to_block (&se->pre, &parmse.pre);
1293 gfc_add_block_to_block (&se->post, &parmse.post);
1295 /* Character strings are passed as two parameters, a length and a
1297 if (parmse.string_length != NULL_TREE)
1298 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1300 arglist = gfc_chainon_list (arglist, parmse.expr);
1303 /* Add the hidden string length parameters to the arguments. */
1304 arglist = chainon (arglist, stringargs);
1306 /* Generate the actual call. */
1307 gfc_conv_function_val (se, sym);
1308 /* If there are alternate return labels, function type should be
1310 if (has_alternate_specifier)
1311 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1313 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1314 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1315 arglist, NULL_TREE);
1320 /* If we have a pointer function, but we don't want a pointer, e.g.
1323 where f is pointer valued, we have to dereference the result. */
1324 if (!se->want_pointer && !byref && sym->attr.pointer)
1325 se->expr = gfc_build_indirect_ref (se->expr);
1327 /* f2c calling conventions require a scalar default real function to
1328 return a double precision result. Convert this back to default
1329 real. We only care about the cases that can happen in Fortran 77.
1331 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1332 && sym->ts.kind == gfc_default_real_kind
1333 && !sym->attr.always_explicit)
1334 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1336 /* A pure function may still have side-effects - it may modify its
1338 TREE_SIDE_EFFECTS (se->expr) = 1;
1340 if (!sym->attr.pure)
1341 TREE_SIDE_EFFECTS (se->expr) = 1;
1346 /* Add the function call to the pre chain. There is no expression. */
1347 gfc_add_expr_to_block (&se->pre, se->expr);
1348 se->expr = NULL_TREE;
1350 if (!se->direct_byref)
1352 if (sym->attr.dimension)
1354 if (flag_bounds_check)
1356 /* Check the data pointer hasn't been modified. This would
1357 happen in a function returning a pointer. */
1358 tmp = gfc_conv_descriptor_data (info->descriptor);
1359 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1360 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1362 se->expr = info->descriptor;
1363 /* Bundle in the string length. */
1364 se->string_length = len;
1366 else if (sym->ts.type == BT_CHARACTER)
1368 /* Dereference for character pointer results. */
1369 if (sym->attr.pointer || sym->attr.allocatable)
1370 se->expr = gfc_build_indirect_ref (var);
1374 se->string_length = len;
1378 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1379 se->expr = gfc_build_indirect_ref (var);
1386 /* Generate code to copy a string. */
1389 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1390 tree slen, tree src)
1395 tmp = gfc_chainon_list (tmp, dlen);
1396 tmp = gfc_chainon_list (tmp, dest);
1397 tmp = gfc_chainon_list (tmp, slen);
1398 tmp = gfc_chainon_list (tmp, src);
1399 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1400 gfc_add_expr_to_block (block, tmp);
1404 /* Translate a statement function.
1405 The value of a statement function reference is obtained by evaluating the
1406 expression using the values of the actual arguments for the values of the
1407 corresponding dummy arguments. */
1410 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1414 gfc_formal_arglist *fargs;
1415 gfc_actual_arglist *args;
1418 gfc_saved_var *saved_vars;
1424 sym = expr->symtree->n.sym;
1425 args = expr->value.function.actual;
1426 gfc_init_se (&lse, NULL);
1427 gfc_init_se (&rse, NULL);
1430 for (fargs = sym->formal; fargs; fargs = fargs->next)
1432 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1433 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1435 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1437 /* Each dummy shall be specified, explicitly or implicitly, to be
1439 gcc_assert (fargs->sym->attr.dimension == 0);
1442 /* Create a temporary to hold the value. */
1443 type = gfc_typenode_for_spec (&fsym->ts);
1444 temp_vars[n] = gfc_create_var (type, fsym->name);
1446 if (fsym->ts.type == BT_CHARACTER)
1448 /* Copy string arguments. */
1451 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1452 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1454 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1455 tmp = gfc_build_addr_expr (build_pointer_type (type),
1458 gfc_conv_expr (&rse, args->expr);
1459 gfc_conv_string_parameter (&rse);
1460 gfc_add_block_to_block (&se->pre, &lse.pre);
1461 gfc_add_block_to_block (&se->pre, &rse.pre);
1463 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1465 gfc_add_block_to_block (&se->pre, &lse.post);
1466 gfc_add_block_to_block (&se->pre, &rse.post);
1470 /* For everything else, just evaluate the expression. */
1471 gfc_conv_expr (&lse, args->expr);
1473 gfc_add_block_to_block (&se->pre, &lse.pre);
1474 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1475 gfc_add_block_to_block (&se->pre, &lse.post);
1481 /* Use the temporary variables in place of the real ones. */
1482 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1483 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1485 gfc_conv_expr (se, sym->value);
1487 if (sym->ts.type == BT_CHARACTER)
1489 gfc_conv_const_charlen (sym->ts.cl);
1491 /* Force the expression to the correct length. */
1492 if (!INTEGER_CST_P (se->string_length)
1493 || tree_int_cst_lt (se->string_length,
1494 sym->ts.cl->backend_decl))
1496 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1497 tmp = gfc_create_var (type, sym->name);
1498 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1499 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1500 se->string_length, se->expr);
1503 se->string_length = sym->ts.cl->backend_decl;
1506 /* Restore the original variables. */
1507 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1508 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1509 gfc_free (saved_vars);
1513 /* Translate a function expression. */
1516 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1520 if (expr->value.function.isym)
1522 gfc_conv_intrinsic_function (se, expr);
1526 /* We distinguish statement functions from general functions to improve
1527 runtime performance. */
1528 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1530 gfc_conv_statement_function (se, expr);
1534 /* expr.value.function.esym is the resolved (specific) function symbol for
1535 most functions. However this isn't set for dummy procedures. */
1536 sym = expr->value.function.esym;
1538 sym = expr->symtree->n.sym;
1539 gfc_conv_function_call (se, sym, expr->value.function.actual);
1544 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1546 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1547 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1549 gfc_conv_tmp_array_ref (se);
1550 gfc_advance_se_ss_chain (se);
1554 /* Build a static initializer. EXPR is the expression for the initial value.
1555 The other parameters describe the variable of the component being
1556 initialized. EXPR may be null. */
1559 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1560 bool array, bool pointer)
1564 if (!(expr || pointer))
1569 /* Arrays need special handling. */
1571 return gfc_build_null_descriptor (type);
1573 return gfc_conv_array_initializer (type, expr);
1576 return fold_convert (type, null_pointer_node);
1582 gfc_init_se (&se, NULL);
1583 gfc_conv_structure (&se, expr, 1);
1587 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1590 gfc_init_se (&se, NULL);
1591 gfc_conv_constant (&se, expr);
1598 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1610 gfc_start_block (&block);
1612 /* Initialize the scalarizer. */
1613 gfc_init_loopinfo (&loop);
1615 gfc_init_se (&lse, NULL);
1616 gfc_init_se (&rse, NULL);
1619 rss = gfc_walk_expr (expr);
1620 if (rss == gfc_ss_terminator)
1622 /* The rhs is scalar. Add a ss for the expression. */
1623 rss = gfc_get_ss ();
1624 rss->next = gfc_ss_terminator;
1625 rss->type = GFC_SS_SCALAR;
1629 /* Create a SS for the destination. */
1630 lss = gfc_get_ss ();
1631 lss->type = GFC_SS_COMPONENT;
1633 lss->shape = gfc_get_shape (cm->as->rank);
1634 lss->next = gfc_ss_terminator;
1635 lss->data.info.dimen = cm->as->rank;
1636 lss->data.info.descriptor = dest;
1637 lss->data.info.data = gfc_conv_array_data (dest);
1638 lss->data.info.offset = gfc_conv_array_offset (dest);
1639 for (n = 0; n < cm->as->rank; n++)
1641 lss->data.info.dim[n] = n;
1642 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1643 lss->data.info.stride[n] = gfc_index_one_node;
1645 mpz_init (lss->shape[n]);
1646 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1647 cm->as->lower[n]->value.integer);
1648 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1651 /* Associate the SS with the loop. */
1652 gfc_add_ss_to_loop (&loop, lss);
1653 gfc_add_ss_to_loop (&loop, rss);
1655 /* Calculate the bounds of the scalarization. */
1656 gfc_conv_ss_startstride (&loop);
1658 /* Setup the scalarizing loops. */
1659 gfc_conv_loop_setup (&loop);
1661 /* Setup the gfc_se structures. */
1662 gfc_copy_loopinfo_to_se (&lse, &loop);
1663 gfc_copy_loopinfo_to_se (&rse, &loop);
1666 gfc_mark_ss_chain_used (rss, 1);
1668 gfc_mark_ss_chain_used (lss, 1);
1670 /* Start the scalarized loop body. */
1671 gfc_start_scalarized_body (&loop, &body);
1673 gfc_conv_tmp_array_ref (&lse);
1674 if (cm->ts.type == BT_CHARACTER)
1675 lse.string_length = cm->ts.cl->backend_decl;
1677 gfc_conv_expr (&rse, expr);
1679 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1680 gfc_add_expr_to_block (&body, tmp);
1682 gcc_assert (rse.ss == gfc_ss_terminator);
1684 /* Generate the copying loops. */
1685 gfc_trans_scalarizing_loops (&loop, &body);
1687 /* Wrap the whole thing up. */
1688 gfc_add_block_to_block (&block, &loop.pre);
1689 gfc_add_block_to_block (&block, &loop.post);
1691 for (n = 0; n < cm->as->rank; n++)
1692 mpz_clear (lss->shape[n]);
1693 gfc_free (lss->shape);
1695 gfc_cleanup_loop (&loop);
1697 return gfc_finish_block (&block);
1700 /* Assign a single component of a derived type constructor. */
1703 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1710 gfc_start_block (&block);
1713 gfc_init_se (&se, NULL);
1714 /* Pointer component. */
1717 /* Array pointer. */
1718 if (expr->expr_type == EXPR_NULL)
1720 dest = gfc_conv_descriptor_data (dest);
1721 tmp = fold_convert (TREE_TYPE (se.expr),
1723 gfc_add_modify_expr (&block, dest, tmp);
1727 rss = gfc_walk_expr (expr);
1728 se.direct_byref = 1;
1730 gfc_conv_expr_descriptor (&se, expr, rss);
1731 gfc_add_block_to_block (&block, &se.pre);
1732 gfc_add_block_to_block (&block, &se.post);
1737 /* Scalar pointers. */
1738 se.want_pointer = 1;
1739 gfc_conv_expr (&se, expr);
1740 gfc_add_block_to_block (&block, &se.pre);
1741 gfc_add_modify_expr (&block, dest,
1742 fold_convert (TREE_TYPE (dest), se.expr));
1743 gfc_add_block_to_block (&block, &se.post);
1746 else if (cm->dimension)
1748 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1749 gfc_add_expr_to_block (&block, tmp);
1751 else if (expr->ts.type == BT_DERIVED)
1753 /* Nested derived type. */
1754 tmp = gfc_trans_structure_assign (dest, expr);
1755 gfc_add_expr_to_block (&block, tmp);
1759 /* Scalar component. */
1762 gfc_init_se (&se, NULL);
1763 gfc_init_se (&lse, NULL);
1765 gfc_conv_expr (&se, expr);
1766 if (cm->ts.type == BT_CHARACTER)
1767 lse.string_length = cm->ts.cl->backend_decl;
1769 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1770 gfc_add_expr_to_block (&block, tmp);
1772 return gfc_finish_block (&block);
1775 /* Assign a derived type constructor to a variable. */
1778 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1786 gfc_start_block (&block);
1787 cm = expr->ts.derived->components;
1788 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1790 /* Skip absent members in default initializers. */
1794 field = cm->backend_decl;
1795 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1796 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1797 gfc_add_expr_to_block (&block, tmp);
1799 return gfc_finish_block (&block);
1802 /* Build an expression for a constructor. If init is nonzero then
1803 this is part of a static variable initializer. */
1806 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1816 gcc_assert (se->ss == NULL);
1817 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1818 type = gfc_typenode_for_spec (&expr->ts);
1822 /* Create a temporary variable and fill it in. */
1823 se->expr = gfc_create_var (type, expr->ts.derived->name);
1824 tmp = gfc_trans_structure_assign (se->expr, expr);
1825 gfc_add_expr_to_block (&se->pre, tmp);
1829 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1832 cm = expr->ts.derived->components;
1833 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1835 /* Skip absent members in default initializers. */
1839 val = gfc_conv_initializer (c->expr, &cm->ts,
1840 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1842 /* Build a TREE_CHAIN to hold it. */
1843 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1845 /* Add it to the list. */
1846 if (tail == NULL_TREE)
1847 TREE_OPERAND(head, 0) = tail = val;
1850 TREE_CHAIN (tail) = val;
1858 /* Translate a substring expression. */
1861 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1867 gcc_assert (ref->type == REF_SUBSTRING);
1869 se->expr = gfc_build_string_const(expr->value.character.length,
1870 expr->value.character.string);
1871 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1872 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1874 gfc_conv_substring(se,ref,expr->ts.kind);
1878 /* Entry point for expression translation. */
1881 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1883 if (se->ss && se->ss->expr == expr
1884 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1886 /* Substitute a scalar expression evaluated outside the scalarization
1888 se->expr = se->ss->data.scalar.expr;
1889 se->string_length = se->ss->string_length;
1890 gfc_advance_se_ss_chain (se);
1894 switch (expr->expr_type)
1897 gfc_conv_expr_op (se, expr);
1901 gfc_conv_function_expr (se, expr);
1905 gfc_conv_constant (se, expr);
1909 gfc_conv_variable (se, expr);
1913 se->expr = null_pointer_node;
1916 case EXPR_SUBSTRING:
1917 gfc_conv_substring_expr (se, expr);
1920 case EXPR_STRUCTURE:
1921 gfc_conv_structure (se, expr, 0);
1925 gfc_conv_array_constructor_expr (se, expr);
1935 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1937 gfc_conv_expr (se, expr);
1938 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1939 figure out a way of rewriting an lvalue so that it has no post chain. */
1940 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1944 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1948 gcc_assert (expr->ts.type != BT_CHARACTER);
1949 gfc_conv_expr (se, expr);
1952 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1953 gfc_add_modify_expr (&se->pre, val, se->expr);
1958 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1960 gfc_conv_expr_val (se, expr);
1961 se->expr = convert (type, se->expr);
1965 /* Converts an expression so that it can be passed by reference. Scalar
1969 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1973 if (se->ss && se->ss->expr == expr
1974 && se->ss->type == GFC_SS_REFERENCE)
1976 se->expr = se->ss->data.scalar.expr;
1977 se->string_length = se->ss->string_length;
1978 gfc_advance_se_ss_chain (se);
1982 if (expr->ts.type == BT_CHARACTER)
1984 gfc_conv_expr (se, expr);
1985 gfc_conv_string_parameter (se);
1989 if (expr->expr_type == EXPR_VARIABLE)
1991 se->want_pointer = 1;
1992 gfc_conv_expr (se, expr);
1995 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1996 gfc_add_modify_expr (&se->pre, var, se->expr);
1997 gfc_add_block_to_block (&se->pre, &se->post);
2003 gfc_conv_expr (se, expr);
2005 /* Create a temporary var to hold the value. */
2006 if (TREE_CONSTANT (se->expr))
2008 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2009 DECL_INITIAL (var) = se->expr;
2014 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2015 gfc_add_modify_expr (&se->pre, var, se->expr);
2017 gfc_add_block_to_block (&se->pre, &se->post);
2019 /* Take the address of that value. */
2020 se->expr = gfc_build_addr_expr (NULL, var);
2025 gfc_trans_pointer_assign (gfc_code * code)
2027 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2031 /* Generate code for a pointer assignment. */
2034 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2042 gfc_start_block (&block);
2044 gfc_init_se (&lse, NULL);
2046 lss = gfc_walk_expr (expr1);
2047 rss = gfc_walk_expr (expr2);
2048 if (lss == gfc_ss_terminator)
2050 /* Scalar pointers. */
2051 lse.want_pointer = 1;
2052 gfc_conv_expr (&lse, expr1);
2053 gcc_assert (rss == gfc_ss_terminator);
2054 gfc_init_se (&rse, NULL);
2055 rse.want_pointer = 1;
2056 gfc_conv_expr (&rse, expr2);
2057 gfc_add_block_to_block (&block, &lse.pre);
2058 gfc_add_block_to_block (&block, &rse.pre);
2059 gfc_add_modify_expr (&block, lse.expr,
2060 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2061 gfc_add_block_to_block (&block, &rse.post);
2062 gfc_add_block_to_block (&block, &lse.post);
2066 /* Array pointer. */
2067 gfc_conv_expr_descriptor (&lse, expr1, lss);
2068 /* Implement Nullify. */
2069 if (expr2->expr_type == EXPR_NULL)
2071 lse.expr = gfc_conv_descriptor_data (lse.expr);
2072 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
2073 gfc_add_modify_expr (&block, lse.expr, rse.expr);
2077 lse.direct_byref = 1;
2078 gfc_conv_expr_descriptor (&lse, expr2, rss);
2080 gfc_add_block_to_block (&block, &lse.pre);
2081 gfc_add_block_to_block (&block, &lse.post);
2083 return gfc_finish_block (&block);
2087 /* Makes sure se is suitable for passing as a function string parameter. */
2088 /* TODO: Need to check all callers fo this function. It may be abused. */
2091 gfc_conv_string_parameter (gfc_se * se)
2095 if (TREE_CODE (se->expr) == STRING_CST)
2097 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2101 type = TREE_TYPE (se->expr);
2102 if (TYPE_STRING_FLAG (type))
2104 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2105 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2108 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2109 gcc_assert (se->string_length
2110 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2114 /* Generate code for assignment of scalar variables. Includes character
2118 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2122 gfc_init_block (&block);
2124 if (type == BT_CHARACTER)
2126 gcc_assert (lse->string_length != NULL_TREE
2127 && rse->string_length != NULL_TREE);
2129 gfc_conv_string_parameter (lse);
2130 gfc_conv_string_parameter (rse);
2132 gfc_add_block_to_block (&block, &lse->pre);
2133 gfc_add_block_to_block (&block, &rse->pre);
2135 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2136 rse->string_length, rse->expr);
2140 gfc_add_block_to_block (&block, &lse->pre);
2141 gfc_add_block_to_block (&block, &rse->pre);
2143 gfc_add_modify_expr (&block, lse->expr,
2144 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2147 gfc_add_block_to_block (&block, &lse->post);
2148 gfc_add_block_to_block (&block, &rse->post);
2150 return gfc_finish_block (&block);
2154 /* Try to translate array(:) = func (...), where func is a transformational
2155 array function, without using a temporary. Returns NULL is this isn't the
2159 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2164 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2165 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2168 /* Elemental functions don't need a temporary anyway. */
2169 if (expr2->symtree->n.sym->attr.elemental)
2172 /* Check for a dependency. */
2173 if (gfc_check_fncall_dependency (expr1, expr2))
2176 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2178 gcc_assert (expr2->value.function.isym
2179 || (gfc_return_by_reference (expr2->value.function.esym)
2180 && expr2->value.function.esym->result->attr.dimension));
2182 ss = gfc_walk_expr (expr1);
2183 gcc_assert (ss != gfc_ss_terminator);
2184 gfc_init_se (&se, NULL);
2185 gfc_start_block (&se.pre);
2186 se.want_pointer = 1;
2188 gfc_conv_array_parameter (&se, expr1, ss, 0);
2190 se.direct_byref = 1;
2191 se.ss = gfc_walk_expr (expr2);
2192 gcc_assert (se.ss != gfc_ss_terminator);
2193 gfc_conv_function_expr (&se, expr2);
2194 gfc_add_block_to_block (&se.pre, &se.post);
2196 return gfc_finish_block (&se.pre);
2200 /* Translate an assignment. Most of the code is concerned with
2201 setting up the scalarizer. */
2204 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2209 gfc_ss *lss_section;
2216 /* Special case a single function returning an array. */
2217 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2219 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2224 /* Assignment of the form lhs = rhs. */
2225 gfc_start_block (&block);
2227 gfc_init_se (&lse, NULL);
2228 gfc_init_se (&rse, NULL);
2231 lss = gfc_walk_expr (expr1);
2233 if (lss != gfc_ss_terminator)
2235 /* The assignment needs scalarization. */
2238 /* Find a non-scalar SS from the lhs. */
2239 while (lss_section != gfc_ss_terminator
2240 && lss_section->type != GFC_SS_SECTION)
2241 lss_section = lss_section->next;
2243 gcc_assert (lss_section != gfc_ss_terminator);
2245 /* Initialize the scalarizer. */
2246 gfc_init_loopinfo (&loop);
2249 rss = gfc_walk_expr (expr2);
2250 if (rss == gfc_ss_terminator)
2252 /* The rhs is scalar. Add a ss for the expression. */
2253 rss = gfc_get_ss ();
2254 rss->next = gfc_ss_terminator;
2255 rss->type = GFC_SS_SCALAR;
2258 /* Associate the SS with the loop. */
2259 gfc_add_ss_to_loop (&loop, lss);
2260 gfc_add_ss_to_loop (&loop, rss);
2262 /* Calculate the bounds of the scalarization. */
2263 gfc_conv_ss_startstride (&loop);
2264 /* Resolve any data dependencies in the statement. */
2265 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2266 /* Setup the scalarizing loops. */
2267 gfc_conv_loop_setup (&loop);
2269 /* Setup the gfc_se structures. */
2270 gfc_copy_loopinfo_to_se (&lse, &loop);
2271 gfc_copy_loopinfo_to_se (&rse, &loop);
2274 gfc_mark_ss_chain_used (rss, 1);
2275 if (loop.temp_ss == NULL)
2278 gfc_mark_ss_chain_used (lss, 1);
2282 lse.ss = loop.temp_ss;
2283 gfc_mark_ss_chain_used (lss, 3);
2284 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2287 /* Start the scalarized loop body. */
2288 gfc_start_scalarized_body (&loop, &body);
2291 gfc_init_block (&body);
2293 /* Translate the expression. */
2294 gfc_conv_expr (&rse, expr2);
2296 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2298 gfc_conv_tmp_array_ref (&lse);
2299 gfc_advance_se_ss_chain (&lse);
2302 gfc_conv_expr (&lse, expr1);
2304 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2305 gfc_add_expr_to_block (&body, tmp);
2307 if (lss == gfc_ss_terminator)
2309 /* Use the scalar assignment as is. */
2310 gfc_add_block_to_block (&block, &body);
2314 gcc_assert (lse.ss == gfc_ss_terminator
2315 && rse.ss == gfc_ss_terminator);
2317 if (loop.temp_ss != NULL)
2319 gfc_trans_scalarized_loop_boundary (&loop, &body);
2321 /* We need to copy the temporary to the actual lhs. */
2322 gfc_init_se (&lse, NULL);
2323 gfc_init_se (&rse, NULL);
2324 gfc_copy_loopinfo_to_se (&lse, &loop);
2325 gfc_copy_loopinfo_to_se (&rse, &loop);
2327 rse.ss = loop.temp_ss;
2330 gfc_conv_tmp_array_ref (&rse);
2331 gfc_advance_se_ss_chain (&rse);
2332 gfc_conv_expr (&lse, expr1);
2334 gcc_assert (lse.ss == gfc_ss_terminator
2335 && rse.ss == gfc_ss_terminator);
2337 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2338 gfc_add_expr_to_block (&body, tmp);
2340 /* Generate the copying loops. */
2341 gfc_trans_scalarizing_loops (&loop, &body);
2343 /* Wrap the whole thing up. */
2344 gfc_add_block_to_block (&block, &loop.pre);
2345 gfc_add_block_to_block (&block, &loop.post);
2347 gfc_cleanup_loop (&loop);
2350 return gfc_finish_block (&block);
2354 gfc_trans_assign (gfc_code * code)
2356 return gfc_trans_assignment (code->expr, code->expr2);