1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004 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"
34 #include "tree-gimple.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (TREE_CODE_CLASS (TREE_CODE (se->expr)) == 'c')
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify_expr (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 assert (sym->attr.dummy && sym->attr.optional);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
139 return build2 (NE_EXPR, boolean_type_node, decl,
140 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Generate code to initialize a string length variable. Returns the
148 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
153 gfc_init_se (&se, NULL);
154 gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
155 gfc_add_block_to_block (pblock, &se.pre);
157 tmp = cl->backend_decl;
158 gfc_add_modify_expr (pblock, tmp, se.expr);
163 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
171 type = gfc_get_character_type (kind, ref->u.ss.length);
172 type = build_pointer_type (type);
175 gfc_init_se (&start, se);
176 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
177 gfc_add_block_to_block (&se->pre, &start.pre);
179 if (integer_onep (start.expr))
180 gfc_conv_string_parameter (se);
183 /* Change the start of the string. */
184 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
187 tmp = gfc_build_indirect_ref (se->expr);
188 tmp = gfc_build_array_ref (tmp, start.expr);
189 se->expr = gfc_build_addr_expr (type, tmp);
192 /* Length = end + 1 - start. */
193 gfc_init_se (&end, se);
194 if (ref->u.ss.end == NULL)
195 end.expr = se->string_length;
198 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
199 gfc_add_block_to_block (&se->pre, &end.pre);
202 build2 (MINUS_EXPR, gfc_strlen_type_node,
203 fold_convert (gfc_strlen_type_node, integer_one_node),
205 tmp = build2 (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
206 se->string_length = fold (tmp);
210 /* Convert a derived type component reference. */
213 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
220 c = ref->u.c.component;
222 assert (c->backend_decl);
224 field = c->backend_decl;
225 assert (TREE_CODE (field) == FIELD_DECL);
227 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
231 if (c->ts.type == BT_CHARACTER)
233 tmp = c->ts.cl->backend_decl;
234 /* Components must always be constant length. */
235 assert (tmp && INTEGER_CST_P (tmp));
236 se->string_length = tmp;
239 if (c->pointer && c->dimension == 0)
240 se->expr = gfc_build_indirect_ref (se->expr);
244 /* Return the contents of a variable. Also handles reference/pointer
245 variables (all Fortran pointer references are implicit). */
248 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
253 sym = expr->symtree->n.sym;
256 /* Check that something hasn't gone horribly wrong. */
257 assert (se->ss != gfc_ss_terminator);
258 assert (se->ss->expr == expr);
260 /* A scalarized term. We already know the descriptor. */
261 se->expr = se->ss->data.info.descriptor;
262 se->string_length = se->ss->string_length;
263 ref = se->ss->data.info.ref;
267 se->expr = gfc_get_symbol_decl (sym);
269 /* Procedure actual arguments. */
270 if (sym->attr.flavor == FL_PROCEDURE
271 && se->expr != current_function_decl)
273 assert (se->want_pointer);
274 if (!sym->attr.dummy)
276 assert (TREE_CODE (se->expr) == FUNCTION_DECL);
277 se->expr = gfc_build_addr_expr (NULL, se->expr);
282 /* Special case for assigning the return value of a function.
283 Self recursive functions must have an explicit return value. */
284 if (se->expr == current_function_decl && sym->attr.function
285 && (sym->result == sym))
287 se->expr = gfc_get_fake_result_decl (sym);
290 /* Dereference scalar dummy variables. */
292 && sym->ts.type != BT_CHARACTER
293 && !sym->attr.dimension)
294 se->expr = gfc_build_indirect_ref (se->expr);
296 /* Dereference pointer variables. */
297 if ((sym->attr.pointer || sym->attr.allocatable)
300 || sym->attr.function
301 || !sym->attr.dimension)
302 && sym->ts.type != BT_CHARACTER)
303 se->expr = gfc_build_indirect_ref (se->expr);
308 /* For character variables, also get the length. */
309 if (sym->ts.type == BT_CHARACTER)
311 se->string_length = sym->ts.cl->backend_decl;
312 assert (se->string_length);
320 /* Return the descriptor if that's what we want and this is an array
321 section reference. */
322 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
324 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
325 /* Return the descriptor for array pointers and allocations. */
327 && ref->next == NULL && (se->descriptor_only))
330 gfc_conv_array_ref (se, &ref->u.ar);
331 /* Return a pointer to an element. */
335 gfc_conv_component_ref (se, ref);
339 gfc_conv_substring (se, ref, expr->ts.kind);
348 /* Pointer assignment, allocation or pass by reference. Arrays are handled
350 if (se->want_pointer)
352 if (expr->ts.type == BT_CHARACTER)
353 gfc_conv_string_parameter (se);
355 se->expr = gfc_build_addr_expr (NULL, se->expr);
358 gfc_advance_se_ss_chain (se);
362 /* Unary ops are easy... Or they would be if ! was a valid op. */
365 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
370 assert (expr->ts.type != BT_CHARACTER);
371 /* Initialize the operand. */
372 gfc_init_se (&operand, se);
373 gfc_conv_expr_val (&operand, expr->op1);
374 gfc_add_block_to_block (&se->pre, &operand.pre);
376 type = gfc_typenode_for_spec (&expr->ts);
378 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
379 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
380 All other unary operators have an equivalent GIMPLE unary operator. */
381 if (code == TRUTH_NOT_EXPR)
382 se->expr = build2 (EQ_EXPR, type, operand.expr,
383 convert (type, integer_zero_node));
385 se->expr = build1 (code, type, operand.expr);
389 /* Expand power operator to optimal multiplications when a value is raised
390 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
391 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
392 Programming", 3rd Edition, 1998. */
394 /* This code is mostly duplicated from expand_powi in the backend.
395 We establish the "optimal power tree" lookup table with the defined size.
396 The items in the table are the exponents used to calculate the index
397 exponents. Any integer n less than the value can get an "addition chain",
398 with the first node being one. */
399 #define POWI_TABLE_SIZE 256
401 /* The table is from builtins.c. */
402 static const unsigned char powi_table[POWI_TABLE_SIZE] =
404 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
405 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
406 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
407 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
408 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
409 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
410 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
411 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
412 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
413 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
414 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
415 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
416 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
417 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
418 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
419 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
420 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
421 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
422 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
423 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
424 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
425 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
426 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
427 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
428 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
429 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
430 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
431 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
432 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
433 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
434 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
435 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
438 /* If n is larger than lookup table's max index, we use the "window
440 #define POWI_WINDOW_SIZE 3
442 /* Recursive function to expand the power operator. The temporary
443 values are put in tmpvar. The function returns tmpvar[1] ** n. */
445 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
452 if (n < POWI_TABLE_SIZE)
457 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
458 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
462 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
463 op0 = gfc_conv_powi (se, n - digit, tmpvar);
464 op1 = gfc_conv_powi (se, digit, tmpvar);
468 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
472 tmp = fold (build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1));
473 tmp = gfc_evaluate_now (tmp, &se->pre);
475 if (n < POWI_TABLE_SIZE)
482 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
483 return 1. Else return 0 and a call to runtime library functions
484 will have to be built. */
486 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
491 tree vartmp[POWI_TABLE_SIZE];
495 type = TREE_TYPE (lhs);
496 n = abs (TREE_INT_CST_LOW (rhs));
497 sgn = tree_int_cst_sgn (rhs);
499 if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
505 se->expr = gfc_build_const (type, integer_one_node);
508 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
509 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
511 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
512 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
513 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
514 convert (TREE_TYPE (lhs), integer_one_node));
517 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
520 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
521 se->expr = build3 (COND_EXPR, type, tmp,
522 convert (type, integer_one_node),
523 convert (type, integer_zero_node));
527 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
528 tmp = build3 (COND_EXPR, type, tmp,
529 convert (type, integer_minus_one_node),
530 convert (type, integer_zero_node));
531 se->expr = build3 (COND_EXPR, type, cond,
532 convert (type, integer_one_node),
537 memset (vartmp, 0, sizeof (vartmp));
541 tmp = gfc_build_const (type, integer_one_node);
542 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
545 se->expr = gfc_conv_powi (se, n, vartmp);
551 /* Power op (**). Constant integer exponent has special handling. */
554 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
563 gfc_init_se (&lse, se);
564 gfc_conv_expr_val (&lse, expr->op1);
565 gfc_add_block_to_block (&se->pre, &lse.pre);
567 gfc_init_se (&rse, se);
568 gfc_conv_expr_val (&rse, expr->op2);
569 gfc_add_block_to_block (&se->pre, &rse.pre);
571 if (expr->op2->ts.type == BT_INTEGER
572 && expr->op2->expr_type == EXPR_CONSTANT)
573 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
576 kind = expr->op1->ts.kind;
577 switch (expr->op2->ts.type)
580 ikind = expr->op2->ts.kind;
585 rse.expr = convert (gfc_int4_type_node, rse.expr);
603 if (expr->op1->ts.type == BT_INTEGER)
604 lse.expr = convert (gfc_int4_type_node, lse.expr);
621 switch (expr->op1->ts.type)
624 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
628 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
632 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
644 fndecl = built_in_decls[BUILT_IN_POWF];
647 fndecl = built_in_decls[BUILT_IN_POW];
658 fndecl = gfor_fndecl_math_cpowf;
661 fndecl = gfor_fndecl_math_cpow;
673 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
674 tmp = gfc_chainon_list (tmp, rse.expr);
675 se->expr = fold (gfc_build_function_call (fndecl, tmp));
679 /* Generate code to allocate a string temporary. */
682 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
688 if (TREE_TYPE (len) != gfc_strlen_type_node)
691 if (gfc_can_put_var_on_stack (len))
693 /* Create a temporary variable to hold the result. */
694 tmp = fold (build2 (MINUS_EXPR, gfc_strlen_type_node, len,
695 convert (gfc_strlen_type_node,
697 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
698 tmp = build_array_type (gfc_character1_type_node, tmp);
699 var = gfc_create_var (tmp, "str");
700 var = gfc_build_addr_expr (type, var);
704 /* Allocate a temporary to hold the result. */
705 var = gfc_create_var (type, "pstr");
706 args = gfc_chainon_list (NULL_TREE, len);
707 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
708 tmp = convert (type, tmp);
709 gfc_add_modify_expr (&se->pre, var, tmp);
711 /* Free the temporary afterwards. */
712 tmp = convert (pvoid_type_node, var);
713 args = gfc_chainon_list (NULL_TREE, tmp);
714 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
715 gfc_add_expr_to_block (&se->post, tmp);
722 /* Handle a string concatenation operation. A temporary will be allocated to
726 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
736 assert (expr->op1->ts.type == BT_CHARACTER
737 && expr->op2->ts.type == BT_CHARACTER);
739 gfc_init_se (&lse, se);
740 gfc_conv_expr (&lse, expr->op1);
741 gfc_conv_string_parameter (&lse);
742 gfc_init_se (&rse, se);
743 gfc_conv_expr (&rse, expr->op2);
744 gfc_conv_string_parameter (&rse);
746 gfc_add_block_to_block (&se->pre, &lse.pre);
747 gfc_add_block_to_block (&se->pre, &rse.pre);
749 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
750 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
751 if (len == NULL_TREE)
753 len = fold (build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
754 lse.string_length, rse.string_length));
757 type = build_pointer_type (type);
759 var = gfc_conv_string_tmp (se, type, len);
761 /* Do the actual concatenation. */
763 args = gfc_chainon_list (args, len);
764 args = gfc_chainon_list (args, var);
765 args = gfc_chainon_list (args, lse.string_length);
766 args = gfc_chainon_list (args, lse.expr);
767 args = gfc_chainon_list (args, rse.string_length);
768 args = gfc_chainon_list (args, rse.expr);
769 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
770 gfc_add_expr_to_block (&se->pre, tmp);
772 /* Add the cleanup for the operands. */
773 gfc_add_block_to_block (&se->pre, &rse.post);
774 gfc_add_block_to_block (&se->pre, &lse.post);
777 se->string_length = len;
781 /* Translates an op expression. Common (binary) cases are handled by this
782 function, others are passed on. Recursion is used in either case.
783 We use the fact that (op1.ts == op2.ts) (except for the power
785 Operators need no special handling for scalarized expressions as long as
786 they call gfc_conv_simple_val to get their operands.
787 Character strings get special handling. */
790 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
802 switch (expr->operator)
804 case INTRINSIC_UPLUS:
805 gfc_conv_expr (se, expr->op1);
808 case INTRINSIC_UMINUS:
809 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
813 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
820 case INTRINSIC_MINUS:
824 case INTRINSIC_TIMES:
828 case INTRINSIC_DIVIDE:
829 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
830 an integer, we must round towards zero, so we use a
832 if (expr->ts.type == BT_INTEGER)
833 code = TRUNC_DIV_EXPR;
838 case INTRINSIC_POWER:
839 gfc_conv_power_op (se, expr);
842 case INTRINSIC_CONCAT:
843 gfc_conv_concat_op (se, expr);
847 code = TRUTH_ANDIF_EXPR;
852 code = TRUTH_ORIF_EXPR;
856 /* EQV and NEQV only work on logicals, but since we represent them
857 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
897 case INTRINSIC_ASSIGN:
898 /* These should be converted into function calls by the frontend. */
903 fatal_error ("Unknown intrinsic op");
907 /* The only exception to this is **, which is handled separately anyway. */
908 assert (expr->op1->ts.type == expr->op2->ts.type);
910 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
914 gfc_init_se (&lse, se);
915 gfc_conv_expr (&lse, expr->op1);
916 gfc_add_block_to_block (&se->pre, &lse.pre);
919 gfc_init_se (&rse, se);
920 gfc_conv_expr (&rse, expr->op2);
921 gfc_add_block_to_block (&se->pre, &rse.pre);
923 /* For string comparisons we generate a library call, and compare the return
927 gfc_conv_string_parameter (&lse);
928 gfc_conv_string_parameter (&rse);
930 tmp = gfc_chainon_list (tmp, lse.string_length);
931 tmp = gfc_chainon_list (tmp, lse.expr);
932 tmp = gfc_chainon_list (tmp, rse.string_length);
933 tmp = gfc_chainon_list (tmp, rse.expr);
935 /* Build a call for the comparison. */
936 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
937 gfc_add_block_to_block (&lse.post, &rse.post);
939 rse.expr = integer_zero_node;
942 type = gfc_typenode_for_spec (&expr->ts);
946 /* The result of logical ops is always boolean_type_node. */
947 tmp = fold (build2 (code, type, lse.expr, rse.expr));
948 se->expr = convert (type, tmp);
951 se->expr = fold (build2 (code, type, lse.expr, rse.expr));
953 /* Add the post blocks. */
954 gfc_add_block_to_block (&se->post, &rse.post);
955 gfc_add_block_to_block (&se->post, &lse.post);
960 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
966 tmp = gfc_get_symbol_decl (sym);
967 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
968 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
974 if (!sym->backend_decl)
975 sym->backend_decl = gfc_get_extern_function_decl (sym);
977 tmp = sym->backend_decl;
978 assert (TREE_CODE (tmp) == FUNCTION_DECL);
979 se->expr = gfc_build_addr_expr (NULL, tmp);
984 /* Generate code for a procedure call. Note can return se->post != NULL.
985 If se->direct_byref is set then se->expr contains the return parameter. */
988 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
989 gfc_actual_arglist * arg)
1002 gfc_formal_arglist *formal;
1004 arglist = NULL_TREE;
1005 stringargs = NULL_TREE;
1011 if (!sym->attr.elemental)
1013 assert (se->ss->type == GFC_SS_FUNCTION);
1014 if (se->ss->useflags)
1016 assert (gfc_return_by_reference (sym)
1017 && sym->result->attr.dimension);
1018 assert (se->loop != NULL);
1020 /* Access the previously obtained result. */
1021 gfc_conv_tmp_array_ref (se);
1022 gfc_advance_se_ss_chain (se);
1026 info = &se->ss->data.info;
1031 byref = gfc_return_by_reference (sym);
1034 if (se->direct_byref)
1035 arglist = gfc_chainon_list (arglist, se->expr);
1036 else if (sym->result->attr.dimension)
1038 assert (se->loop && se->ss);
1039 /* Set the type of the array. */
1040 tmp = gfc_typenode_for_spec (&sym->ts);
1041 info->dimen = se->loop->dimen;
1042 /* Allocate a temporary to store the result. */
1043 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1045 /* Zero the first stride to indicate a temporary. */
1047 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1048 gfc_add_modify_expr (&se->pre, tmp,
1049 convert (TREE_TYPE (tmp), integer_zero_node));
1050 /* Pass the temporary as the first argument. */
1051 tmp = info->descriptor;
1052 tmp = gfc_build_addr_expr (NULL, tmp);
1053 arglist = gfc_chainon_list (arglist, tmp);
1055 else if (sym->ts.type == BT_CHARACTER)
1057 assert (sym->ts.cl && sym->ts.cl->length
1058 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1059 len = gfc_conv_mpz_to_tree
1060 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1061 sym->ts.cl->backend_decl = len;
1062 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1063 type = build_pointer_type (type);
1065 var = gfc_conv_string_tmp (se, type, len);
1066 arglist = gfc_chainon_list (arglist, var);
1067 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1070 else /* TODO: derived type function return values. */
1074 formal = sym->formal;
1075 /* Evaluate the arguments. */
1076 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1078 if (arg->expr == NULL)
1081 if (se->ignore_optional)
1083 /* Some intrinsics have already been resolved to the correct
1087 else if (arg->label)
1089 has_alternate_specifier = 1;
1094 /* Pass a NULL pointer for an absent arg. */
1095 gfc_init_se (&parmse, NULL);
1096 parmse.expr = null_pointer_node;
1097 if (arg->missing_arg_type == BT_CHARACTER)
1100 gfc_chainon_list (stringargs,
1101 convert (gfc_strlen_type_node,
1102 integer_zero_node));
1106 else if (se->ss && se->ss->useflags)
1108 /* An elemental function inside a scalarized loop. */
1109 gfc_init_se (&parmse, se);
1110 gfc_conv_expr_reference (&parmse, arg->expr);
1114 /* A scalar or transformational function. */
1115 gfc_init_se (&parmse, NULL);
1116 argss = gfc_walk_expr (arg->expr);
1118 if (argss == gfc_ss_terminator)
1120 gfc_conv_expr_reference (&parmse, arg->expr);
1121 if (formal && formal->sym->attr.pointer
1122 && arg->expr->expr_type != EXPR_NULL)
1124 /* Scalar pointer dummy args require an extra level of
1125 indirection. The null pointer already contains
1126 this level of indirection. */
1127 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1132 /* If the procedure requires an explicit interface, the
1133 actual argument is passed according to the
1134 corresponding formal argument. If the corresponding
1135 formal argument is a POINTER or assumed shape, we do
1136 not use g77's calling aonvention, and pass the
1137 address of the array descriptor instead. Otherwise we
1138 use g77's calling convention. */
1140 f = (formal != NULL)
1141 && !formal->sym->attr.pointer
1142 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1143 f = f || !sym->attr.always_explicit;
1144 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1148 gfc_add_block_to_block (&se->pre, &parmse.pre);
1149 gfc_add_block_to_block (&se->post, &parmse.post);
1151 /* Character strings are passed as two paramarers, a length and a
1153 if (parmse.string_length != NULL_TREE)
1154 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1156 arglist = gfc_chainon_list (arglist, parmse.expr);
1159 /* Add the hidden string length parameters to the arguments. */
1160 arglist = chainon (arglist, stringargs);
1162 /* Generate the actual call. */
1163 gfc_conv_function_val (se, sym);
1164 /* If there are alternate return labels, function type should be
1166 if (has_alternate_specifier)
1167 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1169 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1170 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1171 arglist, NULL_TREE);
1173 /* A pure function may still have side-effects - it may modify its
1175 TREE_SIDE_EFFECTS (se->expr) = 1;
1177 if (!sym->attr.pure)
1178 TREE_SIDE_EFFECTS (se->expr) = 1;
1183 /* Add the function call to the pre chain. There is no expression. */
1184 gfc_add_expr_to_block (&se->pre, se->expr);
1185 se->expr = NULL_TREE;
1187 if (!se->direct_byref)
1189 if (sym->result->attr.dimension)
1191 if (flag_bounds_check)
1193 /* Check the data pointer hasn't been modified. This would
1194 happen in a function returning a pointer. */
1195 tmp = gfc_conv_descriptor_data (info->descriptor);
1196 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1197 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1199 se->expr = info->descriptor;
1201 else if (sym->ts.type == BT_CHARACTER)
1204 se->string_length = len;
1213 /* Generate code to copy a string. */
1216 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1217 tree slen, tree src)
1222 tmp = gfc_chainon_list (tmp, dlen);
1223 tmp = gfc_chainon_list (tmp, dest);
1224 tmp = gfc_chainon_list (tmp, slen);
1225 tmp = gfc_chainon_list (tmp, src);
1226 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1227 gfc_add_expr_to_block (block, tmp);
1231 /* Translate a statement function.
1232 The value of a statement function reference is obtained by evaluating the
1233 expression using the values of the actual arguments for the values of the
1234 corresponding dummy arguments. */
1237 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1241 gfc_formal_arglist *fargs;
1242 gfc_actual_arglist *args;
1245 gfc_saved_var *saved_vars;
1251 sym = expr->symtree->n.sym;
1252 args = expr->value.function.actual;
1253 gfc_init_se (&lse, NULL);
1254 gfc_init_se (&rse, NULL);
1257 for (fargs = sym->formal; fargs; fargs = fargs->next)
1259 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1260 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1262 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1264 /* Each dummy shall be specified, explicitly or implicitly, to be
1266 assert (fargs->sym->attr.dimension == 0);
1269 /* Create a temporary to hold the value. */
1270 type = gfc_typenode_for_spec (&fsym->ts);
1271 temp_vars[n] = gfc_create_var (type, fsym->name);
1273 if (fsym->ts.type == BT_CHARACTER)
1275 /* Copy string arguments. */
1278 assert (fsym->ts.cl && fsym->ts.cl->length
1279 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1281 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1282 tmp = gfc_build_addr_expr (build_pointer_type (type),
1285 gfc_conv_expr (&rse, args->expr);
1286 gfc_conv_string_parameter (&rse);
1287 gfc_add_block_to_block (&se->pre, &lse.pre);
1288 gfc_add_block_to_block (&se->pre, &rse.pre);
1290 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1292 gfc_add_block_to_block (&se->pre, &lse.post);
1293 gfc_add_block_to_block (&se->pre, &rse.post);
1297 /* For everything else, just evaluate the expression. */
1298 gfc_conv_expr (&lse, args->expr);
1300 gfc_add_block_to_block (&se->pre, &lse.pre);
1301 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1302 gfc_add_block_to_block (&se->pre, &lse.post);
1308 /* Use the temporary variables in place of the real ones. */
1309 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1310 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1312 gfc_conv_expr (se, sym->value);
1314 if (sym->ts.type == BT_CHARACTER)
1316 gfc_conv_const_charlen (sym->ts.cl);
1318 /* Force the expression to the correct length. */
1319 if (!INTEGER_CST_P (se->string_length)
1320 || tree_int_cst_lt (se->string_length,
1321 sym->ts.cl->backend_decl))
1323 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1324 tmp = gfc_create_var (type, sym->name);
1325 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1326 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1327 se->string_length, se->expr);
1330 se->string_length = sym->ts.cl->backend_decl;
1333 /* Restore the original variables. */
1334 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1335 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1336 gfc_free (saved_vars);
1340 /* Translate a function expression. */
1343 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1347 if (expr->value.function.isym)
1349 gfc_conv_intrinsic_function (se, expr);
1353 /* We distinguish statement functions from general functions to improve
1354 runtime performance. */
1355 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1357 gfc_conv_statement_function (se, expr);
1361 /* expr.value.function.esym is the resolved (specific) function symbol for
1362 most functions. However this isn't set for dummy procedures. */
1363 sym = expr->value.function.esym;
1365 sym = expr->symtree->n.sym;
1366 gfc_conv_function_call (se, sym, expr->value.function.actual);
1371 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1373 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1374 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1376 gfc_conv_tmp_array_ref (se);
1377 gfc_advance_se_ss_chain (se);
1381 /* Build a static initializer. EXPR is the expression for the initial value.
1382 The other parameters describe the variable of the component being
1383 initialized. EXPR may be null. */
1386 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1387 bool array, bool pointer)
1391 if (!(expr || pointer))
1396 /* Arrays need special handling. */
1398 return gfc_build_null_descriptor (type);
1400 return gfc_conv_array_initializer (type, expr);
1403 return fold_convert (type, null_pointer_node);
1409 gfc_init_se (&se, NULL);
1410 gfc_conv_structure (&se, expr, 1);
1414 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1417 gfc_init_se (&se, NULL);
1418 gfc_conv_constant (&se, expr);
1425 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1437 gfc_start_block (&block);
1439 /* Initialize the scalarizer. */
1440 gfc_init_loopinfo (&loop);
1442 gfc_init_se (&lse, NULL);
1443 gfc_init_se (&rse, NULL);
1446 rss = gfc_walk_expr (expr);
1447 if (rss == gfc_ss_terminator)
1449 /* The rhs is scalar. Add a ss for the expression. */
1450 rss = gfc_get_ss ();
1451 rss->next = gfc_ss_terminator;
1452 rss->type = GFC_SS_SCALAR;
1456 /* Create a SS for the destination. */
1457 lss = gfc_get_ss ();
1458 lss->type = GFC_SS_COMPONENT;
1460 lss->shape = gfc_get_shape (cm->as->rank);
1461 lss->next = gfc_ss_terminator;
1462 lss->data.info.dimen = cm->as->rank;
1463 lss->data.info.descriptor = dest;
1464 lss->data.info.data = gfc_conv_array_data (dest);
1465 lss->data.info.offset = gfc_conv_array_offset (dest);
1466 for (n = 0; n < cm->as->rank; n++)
1468 lss->data.info.dim[n] = n;
1469 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1470 lss->data.info.stride[n] = gfc_index_one_node;
1472 mpz_init (lss->shape[n]);
1473 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1474 cm->as->lower[n]->value.integer);
1475 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1478 /* Associate the SS with the loop. */
1479 gfc_add_ss_to_loop (&loop, lss);
1480 gfc_add_ss_to_loop (&loop, rss);
1482 /* Calculate the bounds of the scalarization. */
1483 gfc_conv_ss_startstride (&loop);
1485 /* Setup the scalarizing loops. */
1486 gfc_conv_loop_setup (&loop);
1488 /* Setup the gfc_se structures. */
1489 gfc_copy_loopinfo_to_se (&lse, &loop);
1490 gfc_copy_loopinfo_to_se (&rse, &loop);
1493 gfc_mark_ss_chain_used (rss, 1);
1495 gfc_mark_ss_chain_used (lss, 1);
1497 /* Start the scalarized loop body. */
1498 gfc_start_scalarized_body (&loop, &body);
1500 gfc_conv_tmp_array_ref (&lse);
1501 gfc_conv_expr (&rse, expr);
1503 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1504 gfc_add_expr_to_block (&body, tmp);
1506 if (rse.ss != gfc_ss_terminator)
1509 /* Generate the copying loops. */
1510 gfc_trans_scalarizing_loops (&loop, &body);
1512 /* Wrap the whole thing up. */
1513 gfc_add_block_to_block (&block, &loop.pre);
1514 gfc_add_block_to_block (&block, &loop.post);
1516 gfc_cleanup_loop (&loop);
1518 for (n = 0; n < cm->as->rank; n++)
1519 mpz_clear (lss->shape[n]);
1520 gfc_free (lss->shape);
1522 return gfc_finish_block (&block);
1525 /* Assign a single component of a derived type constructor. */
1528 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1535 gfc_start_block (&block);
1538 gfc_init_se (&se, NULL);
1539 /* Pointer component. */
1542 /* Array pointer. */
1543 if (expr->expr_type == EXPR_NULL)
1545 dest = gfc_conv_descriptor_data (dest);
1546 tmp = fold_convert (TREE_TYPE (se.expr),
1548 gfc_add_modify_expr (&block, dest, tmp);
1552 rss = gfc_walk_expr (expr);
1553 se.direct_byref = 1;
1555 gfc_conv_expr_descriptor (&se, expr, rss);
1556 gfc_add_block_to_block (&block, &se.pre);
1557 gfc_add_block_to_block (&block, &se.post);
1562 /* Scalar pointers. */
1563 se.want_pointer = 1;
1564 gfc_conv_expr (&se, expr);
1565 gfc_add_block_to_block (&block, &se.pre);
1566 gfc_add_modify_expr (&block, dest,
1567 fold_convert (TREE_TYPE (dest), se.expr));
1568 gfc_add_block_to_block (&block, &se.post);
1571 else if (cm->dimension)
1573 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1574 gfc_add_expr_to_block (&block, tmp);
1576 else if (expr->ts.type == BT_DERIVED)
1578 /* Nested dervived type. */
1579 tmp = gfc_trans_structure_assign (dest, expr);
1580 gfc_add_expr_to_block (&block, tmp);
1584 /* Scalar component. */
1587 gfc_init_se (&se, NULL);
1588 gfc_init_se (&lse, NULL);
1590 gfc_conv_expr (&se, expr);
1591 if (cm->ts.type == BT_CHARACTER)
1592 lse.string_length = cm->ts.cl->backend_decl;
1594 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1595 gfc_add_expr_to_block (&block, tmp);
1597 return gfc_finish_block (&block);
1600 /* Assign a derived type contructor to a variable. */
1603 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1611 gfc_start_block (&block);
1612 cm = expr->ts.derived->components;
1613 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1615 /* Skip absent members in default initializers. */
1619 field = cm->backend_decl;
1620 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1621 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1622 gfc_add_expr_to_block (&block, tmp);
1624 return gfc_finish_block (&block);
1627 /* Build an expression for a constructor. If init is nonzero then
1628 this is part of a static variable initializer. */
1631 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1641 assert (se->ss == NULL);
1642 assert (expr->expr_type == EXPR_STRUCTURE);
1643 type = gfc_typenode_for_spec (&expr->ts);
1647 /* Create a temporary variable and fill it in. */
1648 se->expr = gfc_create_var (type, expr->ts.derived->name);
1649 tmp = gfc_trans_structure_assign (se->expr, expr);
1650 gfc_add_expr_to_block (&se->pre, tmp);
1654 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1657 cm = expr->ts.derived->components;
1658 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1660 /* Skip absent members in default initializers. */
1664 val = gfc_conv_initializer (c->expr, &cm->ts,
1665 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1667 /* Build a TREE_CHAIN to hold it. */
1668 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1670 /* Add it to the list. */
1671 if (tail == NULL_TREE)
1672 TREE_OPERAND(head, 0) = tail = val;
1675 TREE_CHAIN (tail) = val;
1683 /* Translate a substring expression. */
1686 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1692 assert(ref->type == REF_SUBSTRING);
1694 se->expr = gfc_build_string_const(expr->value.character.length,
1695 expr->value.character.string);
1696 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1697 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1699 gfc_conv_substring(se,ref,expr->ts.kind);
1703 /* Entry point for expression translation. */
1706 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1708 if (se->ss && se->ss->expr == expr
1709 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1711 /* Substitute a scalar expression evaluated outside the scalarization
1713 se->expr = se->ss->data.scalar.expr;
1714 se->string_length = se->ss->string_length;
1715 gfc_advance_se_ss_chain (se);
1719 switch (expr->expr_type)
1722 gfc_conv_expr_op (se, expr);
1726 gfc_conv_function_expr (se, expr);
1730 gfc_conv_constant (se, expr);
1734 gfc_conv_variable (se, expr);
1738 se->expr = null_pointer_node;
1741 case EXPR_SUBSTRING:
1742 gfc_conv_substring_expr (se, expr);
1745 case EXPR_STRUCTURE:
1746 gfc_conv_structure (se, expr, 0);
1750 gfc_conv_array_constructor_expr (se, expr);
1760 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1762 gfc_conv_expr (se, expr);
1763 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1764 figure out a way of rewriting an lvalue so that it has no post chain. */
1765 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1769 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1773 assert (expr->ts.type != BT_CHARACTER);
1774 gfc_conv_expr (se, expr);
1777 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1778 gfc_add_modify_expr (&se->pre, val, se->expr);
1783 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1785 gfc_conv_expr_val (se, expr);
1786 se->expr = convert (type, se->expr);
1790 /* Converts an expression so that it can be passed by reference. Scalar
1794 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1798 if (se->ss && se->ss->expr == expr
1799 && se->ss->type == GFC_SS_REFERENCE)
1801 se->expr = se->ss->data.scalar.expr;
1802 se->string_length = se->ss->string_length;
1803 gfc_advance_se_ss_chain (se);
1807 if (expr->ts.type == BT_CHARACTER)
1809 gfc_conv_expr (se, expr);
1810 gfc_conv_string_parameter (se);
1814 if (expr->expr_type == EXPR_VARIABLE)
1816 se->want_pointer = 1;
1817 gfc_conv_expr (se, expr);
1820 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1821 gfc_add_modify_expr (&se->pre, var, se->expr);
1822 gfc_add_block_to_block (&se->pre, &se->post);
1828 gfc_conv_expr (se, expr);
1830 /* Create a temporary var to hold the value. */
1831 if (TREE_CONSTANT (se->expr))
1833 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1834 DECL_INITIAL (var) = se->expr;
1839 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1840 gfc_add_modify_expr (&se->pre, var, se->expr);
1842 gfc_add_block_to_block (&se->pre, &se->post);
1844 /* Take the address of that value. */
1845 se->expr = gfc_build_addr_expr (NULL, var);
1850 gfc_trans_pointer_assign (gfc_code * code)
1852 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1856 /* Generate code for a pointer assignment. */
1859 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1867 gfc_start_block (&block);
1869 gfc_init_se (&lse, NULL);
1871 lss = gfc_walk_expr (expr1);
1872 rss = gfc_walk_expr (expr2);
1873 if (lss == gfc_ss_terminator)
1875 /* Scalar pointers. */
1876 lse.want_pointer = 1;
1877 gfc_conv_expr (&lse, expr1);
1878 assert (rss == gfc_ss_terminator);
1879 gfc_init_se (&rse, NULL);
1880 rse.want_pointer = 1;
1881 gfc_conv_expr (&rse, expr2);
1882 gfc_add_block_to_block (&block, &lse.pre);
1883 gfc_add_block_to_block (&block, &rse.pre);
1884 gfc_add_modify_expr (&block, lse.expr,
1885 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1886 gfc_add_block_to_block (&block, &rse.post);
1887 gfc_add_block_to_block (&block, &lse.post);
1891 /* Array pointer. */
1892 gfc_conv_expr_descriptor (&lse, expr1, lss);
1893 /* Implement Nullify. */
1894 if (expr2->expr_type == EXPR_NULL)
1896 lse.expr = gfc_conv_descriptor_data (lse.expr);
1897 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1898 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1902 lse.direct_byref = 1;
1903 gfc_conv_expr_descriptor (&lse, expr2, rss);
1905 gfc_add_block_to_block (&block, &lse.pre);
1906 gfc_add_block_to_block (&block, &lse.post);
1908 return gfc_finish_block (&block);
1912 /* Makes sure se is suitable for passing as a function string parameter. */
1913 /* TODO: Need to check all callers fo this function. It may be abused. */
1916 gfc_conv_string_parameter (gfc_se * se)
1920 if (TREE_CODE (se->expr) == STRING_CST)
1922 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1926 type = TREE_TYPE (se->expr);
1927 if (TYPE_STRING_FLAG (type))
1929 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1930 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1933 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1934 assert (se->string_length
1935 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1939 /* Generate code for assignment of scalar variables. Includes character
1943 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1947 gfc_init_block (&block);
1949 if (type == BT_CHARACTER)
1951 assert (lse->string_length != NULL_TREE
1952 && rse->string_length != NULL_TREE);
1954 gfc_conv_string_parameter (lse);
1955 gfc_conv_string_parameter (rse);
1957 gfc_add_block_to_block (&block, &lse->pre);
1958 gfc_add_block_to_block (&block, &rse->pre);
1960 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1961 rse->string_length, rse->expr);
1965 gfc_add_block_to_block (&block, &lse->pre);
1966 gfc_add_block_to_block (&block, &rse->pre);
1968 gfc_add_modify_expr (&block, lse->expr,
1969 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1972 gfc_add_block_to_block (&block, &lse->post);
1973 gfc_add_block_to_block (&block, &rse->post);
1975 return gfc_finish_block (&block);
1979 /* Try to translate array(:) = func (...), where func is a transformational
1980 array function, without using a temporary. Returns NULL is this isn't the
1984 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1989 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1990 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1993 /* Elemental functions don't need a temporary anyway. */
1994 if (expr2->symtree->n.sym->attr.elemental)
1997 /* Check for a dependency. */
1998 if (gfc_check_fncall_dependency (expr1, expr2))
2001 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2003 assert (expr2->value.function.isym
2004 || (gfc_return_by_reference (expr2->symtree->n.sym)
2005 && expr2->symtree->n.sym->result->attr.dimension));
2007 ss = gfc_walk_expr (expr1);
2008 assert (ss != gfc_ss_terminator);
2009 gfc_init_se (&se, NULL);
2010 gfc_start_block (&se.pre);
2011 se.want_pointer = 1;
2013 gfc_conv_array_parameter (&se, expr1, ss, 0);
2015 se.direct_byref = 1;
2016 se.ss = gfc_walk_expr (expr2);
2017 assert (se.ss != gfc_ss_terminator);
2018 gfc_conv_function_expr (&se, expr2);
2019 gfc_add_block_to_block (&se.pre, &se.post);
2021 return gfc_finish_block (&se.pre);
2025 /* Translate an assignment. Most of the code is concerned with
2026 setting up the scalarizer. */
2029 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2034 gfc_ss *lss_section;
2041 /* Special case a single function returning an array. */
2042 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2044 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2049 /* Assignment of the form lhs = rhs. */
2050 gfc_start_block (&block);
2052 gfc_init_se (&lse, NULL);
2053 gfc_init_se (&rse, NULL);
2056 lss = gfc_walk_expr (expr1);
2058 if (lss != gfc_ss_terminator)
2060 /* The assignment needs scalarization. */
2063 /* Find a non-scalar SS from the lhs. */
2064 while (lss_section != gfc_ss_terminator
2065 && lss_section->type != GFC_SS_SECTION)
2066 lss_section = lss_section->next;
2068 assert (lss_section != gfc_ss_terminator);
2070 /* Initialize the scalarizer. */
2071 gfc_init_loopinfo (&loop);
2074 rss = gfc_walk_expr (expr2);
2075 if (rss == gfc_ss_terminator)
2077 /* The rhs is scalar. Add a ss for the expression. */
2078 rss = gfc_get_ss ();
2079 rss->next = gfc_ss_terminator;
2080 rss->type = GFC_SS_SCALAR;
2083 /* Associate the SS with the loop. */
2084 gfc_add_ss_to_loop (&loop, lss);
2085 gfc_add_ss_to_loop (&loop, rss);
2087 /* Calculate the bounds of the scalarization. */
2088 gfc_conv_ss_startstride (&loop);
2089 /* Resolve any data dependencies in the statement. */
2090 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2091 /* Setup the scalarizing loops. */
2092 gfc_conv_loop_setup (&loop);
2094 /* Setup the gfc_se structures. */
2095 gfc_copy_loopinfo_to_se (&lse, &loop);
2096 gfc_copy_loopinfo_to_se (&rse, &loop);
2099 gfc_mark_ss_chain_used (rss, 1);
2100 if (loop.temp_ss == NULL)
2103 gfc_mark_ss_chain_used (lss, 1);
2107 lse.ss = loop.temp_ss;
2108 gfc_mark_ss_chain_used (lss, 3);
2109 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2112 /* Start the scalarized loop body. */
2113 gfc_start_scalarized_body (&loop, &body);
2116 gfc_init_block (&body);
2118 /* Translate the expression. */
2119 gfc_conv_expr (&rse, expr2);
2121 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2123 gfc_conv_tmp_array_ref (&lse);
2124 gfc_advance_se_ss_chain (&lse);
2127 gfc_conv_expr (&lse, expr1);
2129 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2130 gfc_add_expr_to_block (&body, tmp);
2132 if (lss == gfc_ss_terminator)
2134 /* Use the scalar assignment as is. */
2135 gfc_add_block_to_block (&block, &body);
2139 if (lse.ss != gfc_ss_terminator)
2141 if (rse.ss != gfc_ss_terminator)
2144 if (loop.temp_ss != NULL)
2146 gfc_trans_scalarized_loop_boundary (&loop, &body);
2148 /* We need to copy the temporary to the actual lhs. */
2149 gfc_init_se (&lse, NULL);
2150 gfc_init_se (&rse, NULL);
2151 gfc_copy_loopinfo_to_se (&lse, &loop);
2152 gfc_copy_loopinfo_to_se (&rse, &loop);
2154 rse.ss = loop.temp_ss;
2157 gfc_conv_tmp_array_ref (&rse);
2158 gfc_advance_se_ss_chain (&rse);
2159 gfc_conv_expr (&lse, expr1);
2161 if (lse.ss != gfc_ss_terminator)
2164 if (rse.ss != gfc_ss_terminator)
2167 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2168 gfc_add_expr_to_block (&body, tmp);
2170 /* Generate the copying loops. */
2171 gfc_trans_scalarizing_loops (&loop, &body);
2173 /* Wrap the whole thing up. */
2174 gfc_add_block_to_block (&block, &loop.pre);
2175 gfc_add_block_to_block (&block, &loop.post);
2177 gfc_cleanup_loop (&loop);
2180 return gfc_finish_block (&block);
2184 gfc_trans_assign (gfc_code * code)
2186 return gfc_trans_assignment (code->expr, code->expr2);