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 /* Initialise 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 parent 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 consistancy 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 build (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);
162 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
170 type = gfc_get_character_type (kind, ref->u.ss.length);
171 type = build_pointer_type (type);
174 gfc_init_se (&start, se);
175 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
176 gfc_add_block_to_block (&se->pre, &start.pre);
178 if (integer_onep (start.expr))
179 gfc_conv_string_parameter (se);
182 /* Change the start of the string. */
183 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
186 tmp = gfc_build_indirect_ref (se->expr);
187 tmp = gfc_build_array_ref (tmp, start.expr);
188 se->expr = gfc_build_addr_expr (type, tmp);
191 /* Length = end + 1 - start. */
192 gfc_init_se (&end, se);
193 if (ref->u.ss.end == NULL)
194 end.expr = se->string_length;
197 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
198 gfc_add_block_to_block (&se->pre, &end.pre);
201 build (MINUS_EXPR, gfc_strlen_type_node,
202 fold_convert (gfc_strlen_type_node, integer_one_node),
204 tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
205 se->string_length = fold (tmp);
209 /* Convert a derived type component reference. */
212 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
219 c = ref->u.c.component;
221 assert (c->backend_decl);
223 field = c->backend_decl;
224 assert (TREE_CODE (field) == FIELD_DECL);
226 tmp = build (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
230 if (c->ts.type == BT_CHARACTER)
232 tmp = c->ts.cl->backend_decl;
234 if (!INTEGER_CST_P (tmp))
235 gfc_todo_error ("Unknown length character component");
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 ref = se->ss->data.info.ref;
266 se->expr = gfc_get_symbol_decl (sym);
268 /* Procedure actual arguments. */
269 if (sym->attr.flavor == FL_PROCEDURE
270 && se->expr != current_function_decl)
272 assert (se->want_pointer);
273 if (!sym->attr.dummy)
275 assert (TREE_CODE (se->expr) == FUNCTION_DECL);
276 se->expr = gfc_build_addr_expr (NULL, se->expr);
281 /* Special case for assigning the return value of a function.
282 Self recursive functions must have an explicit return value. */
283 if (se->expr == current_function_decl && sym->attr.function
284 && (sym->result == sym))
286 se->expr = gfc_get_fake_result_decl (sym);
289 /* Dereference scalar dummy variables. */
291 && sym->ts.type != BT_CHARACTER
292 && !sym->attr.dimension)
293 se->expr = gfc_build_indirect_ref (se->expr);
295 /* Dereference pointer variables. */
296 if ((sym->attr.pointer || sym->attr.allocatable)
299 || sym->attr.function
300 || !sym->attr.dimension)
301 && sym->ts.type != BT_CHARACTER)
302 se->expr = gfc_build_indirect_ref (se->expr);
307 /* For character variables, also get the length. */
308 if (sym->ts.type == BT_CHARACTER)
310 se->string_length = sym->ts.cl->backend_decl;
311 assert (se->string_length);
319 /* Return the descriptor if that's what we want and this is an array
320 section reference. */
321 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
323 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
324 /* Return the descriptor for array pointers and allocations. */
326 && ref->next == NULL && (se->descriptor_only))
329 gfc_conv_array_ref (se, &ref->u.ar);
330 /* Return a pointer to an element. */
334 gfc_conv_component_ref (se, ref);
338 gfc_conv_substring (se, ref, expr->ts.kind);
347 /* Pointer assignment, allocation or pass by reference. Arrays are handled
349 if (se->want_pointer)
351 if (expr->ts.type == BT_CHARACTER)
352 gfc_conv_string_parameter (se);
354 se->expr = gfc_build_addr_expr (NULL, se->expr);
357 gfc_advance_se_ss_chain (se);
361 /* Unary ops are easy... Or they would be if ! was a valid op. */
364 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
369 assert (expr->ts.type != BT_CHARACTER);
370 /* Initialize the operand. */
371 gfc_init_se (&operand, se);
372 gfc_conv_expr_val (&operand, expr->op1);
373 gfc_add_block_to_block (&se->pre, &operand.pre);
375 type = gfc_typenode_for_spec (&expr->ts);
377 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
378 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
379 All other unary operators have an equivalent GIMPLE unary operator */
380 if (code == TRUTH_NOT_EXPR)
381 se->expr = build (EQ_EXPR, type, operand.expr,
382 convert (type, integer_zero_node));
384 se->expr = build1 (code, type, operand.expr);
388 /* Expand power operator to optimal multiplications when a value is raised
389 to an constant integer n. See section 4.6.3, "Evaluation of Powers" of
390 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
391 Programming", 3rd Edition, 1998. */
393 /* This code is mostly duplicated from expand_powi in the backend.
394 We establish the "optimal power tree" lookup table with the defined size.
395 The items in the table are the exponents used to calculate the index
396 exponents. Any integer n less than the value can get an "addition chain",
397 with the first node being one. */
398 #define POWI_TABLE_SIZE 256
400 /* The table is from Builtins.c. */
401 static const unsigned char powi_table[POWI_TABLE_SIZE] =
403 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
404 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
405 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
406 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
407 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
408 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
409 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
410 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
411 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
412 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
413 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
414 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
415 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
416 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
417 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
418 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
419 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
420 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
421 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
422 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
423 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
424 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
425 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
426 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
427 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
428 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
429 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
430 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
431 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
432 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
433 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
434 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
437 /* If n is larger than lookup table's max index, we use "window method". */
438 #define POWI_WINDOW_SIZE 3
440 /* Recursive function to expand power operator. The temporary values are put
441 in tmpvar. The function return tmpvar[1] ** n. */
443 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
450 if (n < POWI_TABLE_SIZE)
455 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
456 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
460 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
461 op0 = gfc_conv_powi (se, n - digit, tmpvar);
462 op1 = gfc_conv_powi (se, digit, tmpvar);
466 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
470 tmp = fold (build (MULT_EXPR, TREE_TYPE (op0), op0, op1));
471 tmp = gfc_evaluate_now (tmp, &se->pre);
473 if (n < POWI_TABLE_SIZE)
479 /* Expand lhs ** rhs. rhs is an constant integer. If expand successfully,
480 return 1. Else return 0 and will call runtime library functions. */
482 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
487 tree vartmp[POWI_TABLE_SIZE];
491 type = TREE_TYPE (lhs);
492 n = abs (TREE_INT_CST_LOW (rhs));
493 sgn = tree_int_cst_sgn (rhs);
495 if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
501 se->expr = gfc_build_const (type, integer_one_node);
504 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
505 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
507 tmp = build (EQ_EXPR, boolean_type_node, lhs,
508 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
509 cond = build (EQ_EXPR, boolean_type_node, lhs,
510 convert (TREE_TYPE (lhs), integer_one_node));
512 /* If rhs is an even,
513 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
516 tmp = build (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
517 se->expr = build (COND_EXPR, type, tmp,
518 convert (type, integer_one_node),
519 convert (type, integer_zero_node));
523 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
524 tmp = build (COND_EXPR, type, tmp,
525 convert (type, integer_minus_one_node),
526 convert (type, integer_zero_node));
527 se->expr = build (COND_EXPR, type, cond,
528 convert (type, integer_one_node),
533 memset (vartmp, 0, sizeof (vartmp));
537 tmp = gfc_build_const (type, integer_one_node);
538 vartmp[1] = build (RDIV_EXPR, type, tmp, vartmp[1]);
541 se->expr = gfc_conv_powi (se, n, vartmp);
547 /* Power op (**). Constant integer exponent has special handling. */
550 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
559 gfc_init_se (&lse, se);
560 gfc_conv_expr_val (&lse, expr->op1);
561 gfc_add_block_to_block (&se->pre, &lse.pre);
563 gfc_init_se (&rse, se);
564 gfc_conv_expr_val (&rse, expr->op2);
565 gfc_add_block_to_block (&se->pre, &rse.pre);
567 if (expr->op2->ts.type == BT_INTEGER
568 && expr->op2->expr_type == EXPR_CONSTANT)
569 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
572 kind = expr->op1->ts.kind;
573 switch (expr->op2->ts.type)
576 ikind = expr->op2->ts.kind;
581 rse.expr = convert (gfc_int4_type_node, rse.expr);
599 if (expr->op1->ts.type == BT_INTEGER)
600 lse.expr = convert (gfc_int4_type_node, lse.expr);
617 switch (expr->op1->ts.type)
620 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
624 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
628 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
640 fndecl = built_in_decls[BUILT_IN_POWF];
643 fndecl = built_in_decls[BUILT_IN_POW];
654 fndecl = gfor_fndecl_math_cpowf;
657 fndecl = gfor_fndecl_math_cpow;
669 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
670 tmp = gfc_chainon_list (tmp, rse.expr);
671 se->expr = fold (gfc_build_function_call (fndecl, tmp));
675 /* Generate code to allocate a string temporary. */
678 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
684 if (TREE_TYPE (len) != gfc_strlen_type_node)
687 if (gfc_can_put_var_on_stack (len))
689 /* Create a temporary variable to hold the result. */
690 tmp = fold (build (MINUS_EXPR, gfc_strlen_type_node, len,
691 convert (gfc_strlen_type_node,
693 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
694 tmp = build_array_type (gfc_character1_type_node, tmp);
695 var = gfc_create_var (tmp, "str");
696 var = gfc_build_addr_expr (type, var);
700 /* Allocate a temporary to hold the result. */
701 var = gfc_create_var (type, "pstr");
702 args = gfc_chainon_list (NULL_TREE, len);
703 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
704 tmp = convert (type, tmp);
705 gfc_add_modify_expr (&se->pre, var, tmp);
707 /* Free the temporary afterwards. */
708 tmp = convert (pvoid_type_node, var);
709 args = gfc_chainon_list (NULL_TREE, tmp);
710 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
711 gfc_add_expr_to_block (&se->post, tmp);
718 /* Handle a string concatenation operation. A temporary will be allocated to
722 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
732 assert (expr->op1->ts.type == BT_CHARACTER
733 && expr->op2->ts.type == BT_CHARACTER);
735 gfc_init_se (&lse, se);
736 gfc_conv_expr (&lse, expr->op1);
737 gfc_conv_string_parameter (&lse);
738 gfc_init_se (&rse, se);
739 gfc_conv_expr (&rse, expr->op2);
740 gfc_conv_string_parameter (&rse);
742 gfc_add_block_to_block (&se->pre, &lse.pre);
743 gfc_add_block_to_block (&se->pre, &rse.pre);
745 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
746 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
747 if (len == NULL_TREE)
749 len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
750 lse.string_length, rse.string_length));
753 type = build_pointer_type (type);
755 var = gfc_conv_string_tmp (se, type, len);
757 /* Do the actual concatenation. */
759 args = gfc_chainon_list (args, len);
760 args = gfc_chainon_list (args, var);
761 args = gfc_chainon_list (args, lse.string_length);
762 args = gfc_chainon_list (args, lse.expr);
763 args = gfc_chainon_list (args, rse.string_length);
764 args = gfc_chainon_list (args, rse.expr);
765 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
766 gfc_add_expr_to_block (&se->pre, tmp);
768 /* Add the cleanup for the operands. */
769 gfc_add_block_to_block (&se->pre, &rse.post);
770 gfc_add_block_to_block (&se->pre, &lse.post);
773 se->string_length = len;
777 /* Translates an op expression. Common (binary) cases are handled by this
778 function, others are passed on. Recursion is used in either case.
779 We use the fact that (op1.ts == op2.ts) (except for the power
781 Operators need no special handling for scalarized expressions as long as
782 they call gfc_conv_siple_val to get their operands.
783 Character strings get special handling. */
786 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
798 switch (expr->operator)
800 case INTRINSIC_UPLUS:
801 gfc_conv_expr (se, expr->op1);
804 case INTRINSIC_UMINUS:
805 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
809 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
816 case INTRINSIC_MINUS:
820 case INTRINSIC_TIMES:
824 case INTRINSIC_DIVIDE:
825 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
826 an integer, we must round towards zero, so we use a
828 if (expr->ts.type == BT_INTEGER)
829 code = TRUNC_DIV_EXPR;
834 case INTRINSIC_POWER:
835 gfc_conv_power_op (se, expr);
838 case INTRINSIC_CONCAT:
839 gfc_conv_concat_op (se, expr);
843 code = TRUTH_ANDIF_EXPR;
848 code = TRUTH_ORIF_EXPR;
852 /* EQV and NEQV only work on logicals, but since we represent them
853 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
893 case INTRINSIC_ASSIGN:
894 /* These should be converted into function calls by the frontend. */
899 fatal_error ("Unknown intrinsic op");
903 /* The only exception to this is **, which is handled seperately anyway. */
904 assert (expr->op1->ts.type == expr->op2->ts.type);
906 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
910 gfc_init_se (&lse, se);
911 gfc_conv_expr (&lse, expr->op1);
912 gfc_add_block_to_block (&se->pre, &lse.pre);
915 gfc_init_se (&rse, se);
916 gfc_conv_expr (&rse, expr->op2);
917 gfc_add_block_to_block (&se->pre, &rse.pre);
919 /* For string comparisons we generate a library call, and compare the return
923 gfc_conv_string_parameter (&lse);
924 gfc_conv_string_parameter (&rse);
926 tmp = gfc_chainon_list (tmp, lse.string_length);
927 tmp = gfc_chainon_list (tmp, lse.expr);
928 tmp = gfc_chainon_list (tmp, rse.string_length);
929 tmp = gfc_chainon_list (tmp, rse.expr);
931 /* Build a call for the comparison. */
932 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
933 gfc_add_block_to_block (&lse.post, &rse.post);
935 rse.expr = integer_zero_node;
938 type = gfc_typenode_for_spec (&expr->ts);
942 /* The result of logical ops is always boolean_type_node. */
943 tmp = fold (build (code, type, lse.expr, rse.expr));
944 se->expr = convert (type, tmp);
947 se->expr = fold (build (code, type, lse.expr, rse.expr));
950 /* Add the post blocks. */
951 gfc_add_block_to_block (&se->post, &rse.post);
952 gfc_add_block_to_block (&se->post, &lse.post);
956 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
962 tmp = gfc_get_symbol_decl (sym);
963 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
964 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
970 if (!sym->backend_decl)
971 sym->backend_decl = gfc_get_extern_function_decl (sym);
973 tmp = sym->backend_decl;
974 assert (TREE_CODE (tmp) == FUNCTION_DECL);
975 se->expr = gfc_build_addr_expr (NULL, tmp);
980 /* Generate code for a procedure call. Note can return se->post != NULL.
981 If se->direct_byref is set then se->expr contains the return parameter. */
984 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
985 gfc_actual_arglist * arg)
998 gfc_formal_arglist *formal;
1000 arglist = NULL_TREE;
1001 stringargs = NULL_TREE;
1007 if (!sym->attr.elemental)
1009 assert (se->ss->type == GFC_SS_FUNCTION);
1010 if (se->ss->useflags)
1012 assert (gfc_return_by_reference (sym)
1013 && sym->result->attr.dimension);
1014 assert (se->loop != NULL);
1016 /* Access the previously obtained result. */
1017 gfc_conv_tmp_array_ref (se);
1018 gfc_advance_se_ss_chain (se);
1022 info = &se->ss->data.info;
1027 byref = gfc_return_by_reference (sym);
1030 if (se->direct_byref)
1031 arglist = gfc_chainon_list (arglist, se->expr);
1032 else if (sym->result->attr.dimension)
1034 assert (se->loop && se->ss);
1035 /* Set the type of the array. */
1036 tmp = gfc_typenode_for_spec (&sym->ts);
1037 info->dimen = se->loop->dimen;
1038 /* Allocate a temporary to store the result. */
1039 gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
1041 /* Zero the first stride to indicate a temporary. */
1043 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1044 gfc_add_modify_expr (&se->pre, tmp,
1045 convert (TREE_TYPE (tmp), integer_zero_node));
1046 /* Pass the temporary as the first argument. */
1047 tmp = info->descriptor;
1048 tmp = gfc_build_addr_expr (NULL, tmp);
1049 arglist = gfc_chainon_list (arglist, tmp);
1051 else if (sym->ts.type == BT_CHARACTER)
1053 assert (sym->ts.cl && sym->ts.cl->length
1054 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1055 len = gfc_conv_mpz_to_tree
1056 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1057 sym->ts.cl->backend_decl = len;
1058 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1059 type = build_pointer_type (type);
1061 var = gfc_conv_string_tmp (se, type, len);
1062 arglist = gfc_chainon_list (arglist, var);
1063 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1066 else /* TODO: derived type function return values. */
1070 formal = sym->formal;
1071 /* Evaluate the arguments. */
1072 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1074 if (arg->expr == NULL)
1077 if (se->ignore_optional)
1079 /* Some intrinsics have already been resolved to the correct
1083 else if (arg->label)
1085 has_alternate_specifier = 1;
1090 /* Pass a NULL pointer for an absent arg. */
1091 gfc_init_se (&parmse, NULL);
1092 parmse.expr = null_pointer_node;
1093 if (arg->missing_arg_type == BT_CHARACTER)
1096 gfc_chainon_list (stringargs,
1097 convert (gfc_strlen_type_node,
1098 integer_zero_node));
1102 else if (se->ss && se->ss->useflags)
1104 /* An elemental function inside a scalarized loop. */
1105 gfc_init_se (&parmse, se);
1106 gfc_conv_expr_reference (&parmse, arg->expr);
1110 /* A scalar or transformational function. */
1111 gfc_init_se (&parmse, NULL);
1112 argss = gfc_walk_expr (arg->expr);
1114 if (argss == gfc_ss_terminator)
1116 gfc_conv_expr_reference (&parmse, arg->expr);
1117 if (formal && formal->sym->attr.pointer
1118 && arg->expr->expr_type != EXPR_NULL)
1120 /* Scalar pointer dummy args require an extra level of
1121 indirection. The null pointer already contains
1122 this level of indirection. */
1123 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1128 /* If the procedure requires explicit interface, actual argument
1129 is passed according to corresponing formal argument. We
1130 do not use g77 method and the address of array descriptor
1131 is passed if corresponing formal is pointer or
1132 assumed-shape, Otherwise use g77 method. */
1134 f = (formal != NULL)
1135 && !formal->sym->attr.pointer
1136 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1137 f = f || !sym->attr.always_explicit;
1138 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1142 gfc_add_block_to_block (&se->pre, &parmse.pre);
1143 gfc_add_block_to_block (&se->post, &parmse.post);
1145 /* Character strings are passed as two paramarers, a length and a
1147 if (parmse.string_length != NULL_TREE)
1148 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1150 arglist = gfc_chainon_list (arglist, parmse.expr);
1153 /* Add the hidden string length parameters to the arguments. */
1154 arglist = chainon (arglist, stringargs);
1156 /* Generate the actual call. */
1157 gfc_conv_function_val (se, sym);
1158 /* If there are alternate return labels, function type should be
1160 if (has_alternate_specifier)
1161 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1163 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1164 se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1165 arglist, NULL_TREE);
1167 /* A pure function may still have side-effects - it may modify its
1169 TREE_SIDE_EFFECTS (se->expr) = 1;
1171 if (!sym->attr.pure)
1172 TREE_SIDE_EFFECTS (se->expr) = 1;
1177 /* Add the function call to the pre chain. There is no expression. */
1178 gfc_add_expr_to_block (&se->pre, se->expr);
1179 se->expr = NULL_TREE;
1181 if (!se->direct_byref)
1183 if (sym->result->attr.dimension)
1185 if (flag_bounds_check)
1187 /* Check the data pointer hasn't been modified. This would
1188 happen in a function returning a pointer. */
1189 tmp = gfc_conv_descriptor_data (info->descriptor);
1190 tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
1191 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1193 se->expr = info->descriptor;
1195 else if (sym->ts.type == BT_CHARACTER)
1198 se->string_length = len;
1207 /* Generate code to copy a string. */
1210 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1211 tree slen, tree src)
1216 tmp = gfc_chainon_list (tmp, dlen);
1217 tmp = gfc_chainon_list (tmp, dest);
1218 tmp = gfc_chainon_list (tmp, slen);
1219 tmp = gfc_chainon_list (tmp, src);
1220 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1221 gfc_add_expr_to_block (block, tmp);
1225 /* Translate a statement function.
1226 The value of a statement function reference is obtained by evaluating the
1227 expression using the values of the actual arguments for the values of the
1228 corresponding dummy arguments. */
1231 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1235 gfc_formal_arglist *fargs;
1236 gfc_actual_arglist *args;
1239 gfc_saved_var *saved_vars;
1245 sym = expr->symtree->n.sym;
1246 args = expr->value.function.actual;
1247 gfc_init_se (&lse, NULL);
1248 gfc_init_se (&rse, NULL);
1251 for (fargs = sym->formal; fargs; fargs = fargs->next)
1253 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1254 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1256 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1258 /* Each dummy shall be specified, explicitly or implicitly, to be
1260 assert (fargs->sym->attr.dimension == 0);
1263 /* Create a temporary to hold the value. */
1264 type = gfc_typenode_for_spec (&fsym->ts);
1265 temp_vars[n] = gfc_create_var (type, fsym->name);
1267 if (fsym->ts.type == BT_CHARACTER)
1269 /* Copy string arguments. */
1272 assert (fsym->ts.cl && fsym->ts.cl->length
1273 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1275 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1276 tmp = gfc_build_addr_expr (build_pointer_type (type),
1279 gfc_conv_expr (&rse, args->expr);
1280 gfc_conv_string_parameter (&rse);
1281 gfc_add_block_to_block (&se->pre, &lse.pre);
1282 gfc_add_block_to_block (&se->pre, &rse.pre);
1284 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1286 gfc_add_block_to_block (&se->pre, &lse.post);
1287 gfc_add_block_to_block (&se->pre, &rse.post);
1291 /* For everything else, just evaluate the expression. */
1292 gfc_conv_expr (&lse, args->expr);
1294 gfc_add_block_to_block (&se->pre, &lse.pre);
1295 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1296 gfc_add_block_to_block (&se->pre, &lse.post);
1302 /* Use the temporary variables in place of the real ones. */
1303 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1304 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1306 gfc_conv_expr (se, sym->value);
1308 if (sym->ts.type == BT_CHARACTER)
1310 gfc_conv_const_charlen (sym->ts.cl);
1312 /* Force the expression to the correct length. */
1313 if (!INTEGER_CST_P (se->string_length)
1314 || tree_int_cst_lt (se->string_length,
1315 sym->ts.cl->backend_decl))
1317 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1318 tmp = gfc_create_var (type, sym->name);
1319 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1320 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1321 se->string_length, se->expr);
1324 se->string_length = sym->ts.cl->backend_decl;
1327 /* Resore the original variables. */
1328 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1329 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1330 gfc_free (saved_vars);
1334 /* Translate a function expression. */
1337 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1341 if (expr->value.function.isym)
1343 gfc_conv_intrinsic_function (se, expr);
1347 /* We distinguish the statement function from general function to improve
1348 runtime performance. */
1349 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1351 gfc_conv_statement_function (se, expr);
1355 /* expr.value.function.esym is the resolved (specific) function symbol for
1356 most functions. However this isn't set for dummy procedures. */
1357 sym = expr->value.function.esym;
1359 sym = expr->symtree->n.sym;
1360 gfc_conv_function_call (se, sym, expr->value.function.actual);
1364 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1366 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1367 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1369 gfc_conv_tmp_array_ref (se);
1370 gfc_advance_se_ss_chain (se);
1374 /* Build a static initializer. EXPR is the expression for the initial value.
1375 The other parameters describe the variable of component being initialized.
1376 EXPR may be null. */
1379 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1380 bool array, bool pointer)
1384 if (!(expr || pointer))
1389 /* Arrays need special handling. */
1391 return gfc_build_null_descriptor (type);
1393 return gfc_conv_array_initializer (type, expr);
1396 return fold_convert (type, null_pointer_node);
1402 gfc_init_se (&se, NULL);
1403 gfc_conv_structure (&se, expr, 1);
1407 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1410 gfc_init_se (&se, NULL);
1411 gfc_conv_constant (&se, expr);
1418 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1430 gfc_start_block (&block);
1432 /* Initialize the scalarizer. */
1433 gfc_init_loopinfo (&loop);
1435 gfc_init_se (&lse, NULL);
1436 gfc_init_se (&rse, NULL);
1439 rss = gfc_walk_expr (expr);
1440 if (rss == gfc_ss_terminator)
1442 /* The rhs is scalar. Add a ss for the expression. */
1443 rss = gfc_get_ss ();
1444 rss->next = gfc_ss_terminator;
1445 rss->type = GFC_SS_SCALAR;
1449 /* Create a SS for the destination. */
1450 lss = gfc_get_ss ();
1451 lss->type = GFC_SS_COMPONENT;
1453 lss->shape = gfc_get_shape (cm->as->rank);
1454 lss->next = gfc_ss_terminator;
1455 lss->data.info.dimen = cm->as->rank;
1456 lss->data.info.descriptor = dest;
1457 lss->data.info.data = gfc_conv_array_data (dest);
1458 lss->data.info.offset = gfc_conv_array_offset (dest);
1459 for (n = 0; n < cm->as->rank; n++)
1461 lss->data.info.dim[n] = n;
1462 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1463 lss->data.info.stride[n] = gfc_index_one_node;
1465 mpz_init (lss->shape[n]);
1466 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1467 cm->as->lower[n]->value.integer);
1468 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1471 /* Associate the SS with the loop. */
1472 gfc_add_ss_to_loop (&loop, lss);
1473 gfc_add_ss_to_loop (&loop, rss);
1475 /* Calculate the bounds of the scalarization. */
1476 gfc_conv_ss_startstride (&loop);
1478 /* Setup the scalarizing loops. */
1479 gfc_conv_loop_setup (&loop);
1481 /* Setup the gfc_se structures. */
1482 gfc_copy_loopinfo_to_se (&lse, &loop);
1483 gfc_copy_loopinfo_to_se (&rse, &loop);
1486 gfc_mark_ss_chain_used (rss, 1);
1488 gfc_mark_ss_chain_used (lss, 1);
1490 /* Start the scalarized loop body. */
1491 gfc_start_scalarized_body (&loop, &body);
1493 gfc_conv_tmp_array_ref (&lse);
1494 gfc_conv_expr (&rse, expr);
1496 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1497 gfc_add_expr_to_block (&body, tmp);
1499 if (rse.ss != gfc_ss_terminator)
1502 /* Generate the copying loops. */
1503 gfc_trans_scalarizing_loops (&loop, &body);
1505 /* Wrap the whole thing up. */
1506 gfc_add_block_to_block (&block, &loop.pre);
1507 gfc_add_block_to_block (&block, &loop.post);
1509 gfc_cleanup_loop (&loop);
1511 for (n = 0; n < cm->as->rank; n++)
1512 mpz_clear (lss->shape[n]);
1513 gfc_free (lss->shape);
1515 return gfc_finish_block (&block);
1518 /* Assign a single component of a derived type constructor. */
1521 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1528 gfc_start_block (&block);
1531 gfc_init_se (&se, NULL);
1532 /* Pointer component. */
1535 /* Array pointer. */
1536 if (expr->expr_type == EXPR_NULL)
1538 dest = gfc_conv_descriptor_data (dest);
1539 tmp = fold_convert (TREE_TYPE (se.expr),
1541 gfc_add_modify_expr (&block, dest, tmp);
1545 rss = gfc_walk_expr (expr);
1546 se.direct_byref = 1;
1548 gfc_conv_expr_descriptor (&se, expr, rss);
1549 gfc_add_block_to_block (&block, &se.pre);
1550 gfc_add_block_to_block (&block, &se.post);
1555 /* Scalar pointers. */
1556 se.want_pointer = 1;
1557 gfc_conv_expr (&se, expr);
1558 gfc_add_block_to_block (&block, &se.pre);
1559 gfc_add_modify_expr (&block, dest,
1560 fold_convert (TREE_TYPE (dest), se.expr));
1561 gfc_add_block_to_block (&block, &se.post);
1564 else if (cm->dimension)
1566 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1567 gfc_add_expr_to_block (&block, tmp);
1569 else if (expr->ts.type == BT_DERIVED)
1571 /* Nested dervived type. */
1572 tmp = gfc_trans_structure_assign (dest, expr);
1573 gfc_add_expr_to_block (&block, tmp);
1577 /* Scalar component. */
1580 gfc_init_se (&se, NULL);
1581 gfc_init_se (&lse, NULL);
1583 gfc_conv_expr (&se, expr);
1584 if (cm->ts.type == BT_CHARACTER)
1585 lse.string_length = cm->ts.cl->backend_decl;
1587 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1588 gfc_add_expr_to_block (&block, tmp);
1590 return gfc_finish_block (&block);
1593 /* Assign a derived type contructor to a variable. */
1596 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1604 gfc_start_block (&block);
1605 cm = expr->ts.derived->components;
1606 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1608 /* Skip absent members in default initializers. */
1612 field = cm->backend_decl;
1613 tmp = build (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1614 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1615 gfc_add_expr_to_block (&block, tmp);
1617 return gfc_finish_block (&block);
1620 /* Build an expression for a constructor. If init is nonzero then
1621 this is part of a static variable initializer. */
1624 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1634 assert (se->ss == NULL);
1635 assert (expr->expr_type == EXPR_STRUCTURE);
1636 type = gfc_typenode_for_spec (&expr->ts);
1640 /* Create a temporary variable and fill it in. */
1641 se->expr = gfc_create_var (type, expr->ts.derived->name);
1642 tmp = gfc_trans_structure_assign (se->expr, expr);
1643 gfc_add_expr_to_block (&se->pre, tmp);
1647 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1650 cm = expr->ts.derived->components;
1651 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1653 /* Skip absent members in default initializers. */
1657 val = gfc_conv_initializer (c->expr, &cm->ts,
1658 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1660 /* Build a TREE_CHAIN to hold it. */
1661 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1663 /* Add it to the list. */
1664 if (tail == NULL_TREE)
1665 TREE_OPERAND(head, 0) = tail = val;
1668 TREE_CHAIN (tail) = val;
1676 /*translate a substring expression */
1679 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1685 assert(ref->type == REF_SUBSTRING);
1687 se->expr = gfc_build_string_const(expr->value.character.length,
1688 expr->value.character.string);
1689 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1690 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1692 gfc_conv_substring(se,ref,expr->ts.kind);
1696 /* Entry point for expression translation. */
1699 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1701 if (se->ss && se->ss->expr == expr
1702 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1704 /* Substitute a scalar expression evaluated outside the scalarization
1706 se->expr = se->ss->data.scalar.expr;
1707 se->string_length = se->ss->data.scalar.string_length;
1708 gfc_advance_se_ss_chain (se);
1712 switch (expr->expr_type)
1715 gfc_conv_expr_op (se, expr);
1719 gfc_conv_function_expr (se, expr);
1723 gfc_conv_constant (se, expr);
1727 gfc_conv_variable (se, expr);
1731 se->expr = null_pointer_node;
1734 case EXPR_SUBSTRING:
1735 gfc_conv_substring_expr (se, expr);
1738 case EXPR_STRUCTURE:
1739 gfc_conv_structure (se, expr, 0);
1743 gfc_conv_array_constructor_expr (se, expr);
1753 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1755 gfc_conv_expr (se, expr);
1756 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1757 figure out a way of rewriting an lvalue so that it has no post chain. */
1758 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1762 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1766 assert (expr->ts.type != BT_CHARACTER);
1767 gfc_conv_expr (se, expr);
1770 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1771 gfc_add_modify_expr (&se->pre, val, se->expr);
1776 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1778 gfc_conv_expr_val (se, expr);
1779 se->expr = convert (type, se->expr);
1783 /* Converts an expression so that it can be passed by refernece. Scalar
1787 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1791 if (se->ss && se->ss->expr == expr
1792 && se->ss->type == GFC_SS_REFERENCE)
1794 se->expr = se->ss->data.scalar.expr;
1795 se->string_length = se->ss->data.scalar.string_length;
1796 gfc_advance_se_ss_chain (se);
1800 if (expr->ts.type == BT_CHARACTER)
1802 gfc_conv_expr (se, expr);
1803 gfc_conv_string_parameter (se);
1807 if (expr->expr_type == EXPR_VARIABLE)
1809 se->want_pointer = 1;
1810 gfc_conv_expr (se, expr);
1813 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1814 gfc_add_modify_expr (&se->pre, var, se->expr);
1815 gfc_add_block_to_block (&se->pre, &se->post);
1821 gfc_conv_expr (se, expr);
1823 /* Create a temporary var to hold the value. */
1824 if (TREE_CONSTANT (se->expr))
1826 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1827 DECL_INITIAL (var) = se->expr;
1832 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1833 gfc_add_modify_expr (&se->pre, var, se->expr);
1835 gfc_add_block_to_block (&se->pre, &se->post);
1837 /* Take the address of that value. */
1838 se->expr = gfc_build_addr_expr (NULL, var);
1843 gfc_trans_pointer_assign (gfc_code * code)
1845 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1849 /* Generate code for a pointer assignment. */
1852 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1860 gfc_start_block (&block);
1862 gfc_init_se (&lse, NULL);
1864 lss = gfc_walk_expr (expr1);
1865 rss = gfc_walk_expr (expr2);
1866 if (lss == gfc_ss_terminator)
1868 /* Scalar pointers. */
1869 lse.want_pointer = 1;
1870 gfc_conv_expr (&lse, expr1);
1871 assert (rss == gfc_ss_terminator);
1872 gfc_init_se (&rse, NULL);
1873 rse.want_pointer = 1;
1874 gfc_conv_expr (&rse, expr2);
1875 gfc_add_block_to_block (&block, &lse.pre);
1876 gfc_add_block_to_block (&block, &rse.pre);
1877 gfc_add_modify_expr (&block, lse.expr,
1878 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1879 gfc_add_block_to_block (&block, &rse.post);
1880 gfc_add_block_to_block (&block, &lse.post);
1884 /* Array pointer. */
1885 gfc_conv_expr_descriptor (&lse, expr1, lss);
1886 /* Implement Nullify. */
1887 if (expr2->expr_type == EXPR_NULL)
1889 lse.expr = gfc_conv_descriptor_data (lse.expr);
1890 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1891 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1895 lse.direct_byref = 1;
1896 gfc_conv_expr_descriptor (&lse, expr2, rss);
1898 gfc_add_block_to_block (&block, &lse.pre);
1899 gfc_add_block_to_block (&block, &lse.post);
1901 return gfc_finish_block (&block);
1905 /* Makes sure se is suitable for passing as a function string parameter. */
1906 /* TODO: Need to check all callers fo this function. It may be abused. */
1909 gfc_conv_string_parameter (gfc_se * se)
1913 if (TREE_CODE (se->expr) == STRING_CST)
1915 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1919 type = TREE_TYPE (se->expr);
1920 if (TYPE_STRING_FLAG (type))
1922 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1923 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1926 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1927 assert (se->string_length
1928 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1932 /* Generate code for assignment of scalar variables. Includes character
1936 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1940 gfc_init_block (&block);
1942 if (type == BT_CHARACTER)
1944 assert (lse->string_length != NULL_TREE
1945 && rse->string_length != NULL_TREE);
1947 gfc_conv_string_parameter (lse);
1948 gfc_conv_string_parameter (rse);
1950 gfc_add_block_to_block (&block, &lse->pre);
1951 gfc_add_block_to_block (&block, &rse->pre);
1953 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1954 rse->string_length, rse->expr);
1958 gfc_add_block_to_block (&block, &lse->pre);
1959 gfc_add_block_to_block (&block, &rse->pre);
1961 gfc_add_modify_expr (&block, lse->expr,
1962 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1965 gfc_add_block_to_block (&block, &lse->post);
1966 gfc_add_block_to_block (&block, &rse->post);
1968 return gfc_finish_block (&block);
1972 /* Try to translate array(:) = func (...), where func is a transformational
1973 array function, without using a temporary. Returns NULL is this isn't the
1977 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1982 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1983 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1986 /* Elemental functions don't need a temporary anyway. */
1987 if (expr2->symtree->n.sym->attr.elemental)
1990 /* Check for a dependency. */
1991 if (gfc_check_fncall_dependency (expr1, expr2))
1994 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1996 assert (expr2->value.function.isym
1997 || (gfc_return_by_reference (expr2->symtree->n.sym)
1998 && expr2->symtree->n.sym->result->attr.dimension));
2000 ss = gfc_walk_expr (expr1);
2001 assert (ss != gfc_ss_terminator);
2002 gfc_init_se (&se, NULL);
2003 gfc_start_block (&se.pre);
2004 se.want_pointer = 1;
2006 gfc_conv_array_parameter (&se, expr1, ss, 0);
2008 se.direct_byref = 1;
2009 se.ss = gfc_walk_expr (expr2);
2010 assert (se.ss != gfc_ss_terminator);
2011 gfc_conv_function_expr (&se, expr2);
2012 gfc_add_block_to_block (&se.pre, &se.post);
2014 return gfc_finish_block (&se.pre);
2018 /* Translate an assignment. Most of the code is concerned with
2019 setting up the scalarizer. */
2022 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2027 gfc_ss *lss_section;
2034 /* Special case a single function returning an array. */
2035 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2037 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2042 /* Assignment of the form lhs = rhs. */
2043 gfc_start_block (&block);
2045 gfc_init_se (&lse, NULL);
2046 gfc_init_se (&rse, NULL);
2049 lss = gfc_walk_expr (expr1);
2051 if (lss != gfc_ss_terminator)
2053 /* The assignment needs scalarization. */
2056 /* Find a non-scalar SS from the lhs. */
2057 while (lss_section != gfc_ss_terminator
2058 && lss_section->type != GFC_SS_SECTION)
2059 lss_section = lss_section->next;
2061 assert (lss_section != gfc_ss_terminator);
2063 /* Initialize the scalarizer. */
2064 gfc_init_loopinfo (&loop);
2067 rss = gfc_walk_expr (expr2);
2068 if (rss == gfc_ss_terminator)
2070 /* The rhs is scalar. Add a ss for the expression. */
2071 rss = gfc_get_ss ();
2072 rss->next = gfc_ss_terminator;
2073 rss->type = GFC_SS_SCALAR;
2076 /* Associate the SS with the loop. */
2077 gfc_add_ss_to_loop (&loop, lss);
2078 gfc_add_ss_to_loop (&loop, rss);
2080 /* Calculate the bounds of the scalarization. */
2081 gfc_conv_ss_startstride (&loop);
2082 /* Resolve any data dependencies in the statement. */
2083 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2084 /* Setup the scalarizing loops. */
2085 gfc_conv_loop_setup (&loop);
2087 /* Setup the gfc_se structures. */
2088 gfc_copy_loopinfo_to_se (&lse, &loop);
2089 gfc_copy_loopinfo_to_se (&rse, &loop);
2092 gfc_mark_ss_chain_used (rss, 1);
2093 if (loop.temp_ss == NULL)
2096 gfc_mark_ss_chain_used (lss, 1);
2100 lse.ss = loop.temp_ss;
2101 gfc_mark_ss_chain_used (lss, 3);
2102 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2105 /* Start the scalarized loop body. */
2106 gfc_start_scalarized_body (&loop, &body);
2109 gfc_init_block (&body);
2111 /* Translate the expression. */
2112 gfc_conv_expr (&rse, expr2);
2114 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2116 gfc_conv_tmp_array_ref (&lse);
2117 gfc_advance_se_ss_chain (&lse);
2120 gfc_conv_expr (&lse, expr1);
2122 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2123 gfc_add_expr_to_block (&body, tmp);
2125 if (lss == gfc_ss_terminator)
2127 /* Use the scalar assignment as is. */
2128 gfc_add_block_to_block (&block, &body);
2132 if (lse.ss != gfc_ss_terminator)
2134 if (rse.ss != gfc_ss_terminator)
2137 if (loop.temp_ss != NULL)
2139 gfc_trans_scalarized_loop_boundary (&loop, &body);
2141 /* We need to copy the temporary to the actual lhs. */
2142 gfc_init_se (&lse, NULL);
2143 gfc_init_se (&rse, NULL);
2144 gfc_copy_loopinfo_to_se (&lse, &loop);
2145 gfc_copy_loopinfo_to_se (&rse, &loop);
2147 rse.ss = loop.temp_ss;
2150 gfc_conv_tmp_array_ref (&rse);
2151 gfc_advance_se_ss_chain (&rse);
2152 gfc_conv_expr (&lse, expr1);
2154 if (lse.ss != gfc_ss_terminator)
2157 if (rse.ss != gfc_ss_terminator)
2160 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2161 gfc_add_expr_to_block (&body, tmp);
2163 /* Generate the copying loops. */
2164 gfc_trans_scalarizing_loops (&loop, &body);
2166 /* Wrap the whole thing up. */
2167 gfc_add_block_to_block (&block, &loop.pre);
2168 gfc_add_block_to_block (&block, &loop.post);
2170 gfc_cleanup_loop (&loop);
2173 return gfc_finish_block (&block);
2177 gfc_trans_assign (gfc_code * code)
2179 return gfc_trans_assignment (code->expr, code->expr2);