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 /* If we have a pointer function, but we don't want a pointer, e.g.
1176 where f is pointer valued, we have to dereference the result. */
1177 if (sym->attr.pointer && !se->want_pointer && !byref)
1178 se->expr = gfc_build_indirect_ref (se->expr);
1180 /* A pure function may still have side-effects - it may modify its
1182 TREE_SIDE_EFFECTS (se->expr) = 1;
1184 if (!sym->attr.pure)
1185 TREE_SIDE_EFFECTS (se->expr) = 1;
1190 /* Add the function call to the pre chain. There is no expression. */
1191 gfc_add_expr_to_block (&se->pre, se->expr);
1192 se->expr = NULL_TREE;
1194 if (!se->direct_byref)
1196 if (sym->result->attr.dimension)
1198 if (flag_bounds_check)
1200 /* Check the data pointer hasn't been modified. This would
1201 happen in a function returning a pointer. */
1202 tmp = gfc_conv_descriptor_data (info->descriptor);
1203 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1204 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1206 se->expr = info->descriptor;
1208 else if (sym->ts.type == BT_CHARACTER)
1211 se->string_length = len;
1220 /* Generate code to copy a string. */
1223 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1224 tree slen, tree src)
1229 tmp = gfc_chainon_list (tmp, dlen);
1230 tmp = gfc_chainon_list (tmp, dest);
1231 tmp = gfc_chainon_list (tmp, slen);
1232 tmp = gfc_chainon_list (tmp, src);
1233 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1234 gfc_add_expr_to_block (block, tmp);
1238 /* Translate a statement function.
1239 The value of a statement function reference is obtained by evaluating the
1240 expression using the values of the actual arguments for the values of the
1241 corresponding dummy arguments. */
1244 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1248 gfc_formal_arglist *fargs;
1249 gfc_actual_arglist *args;
1252 gfc_saved_var *saved_vars;
1258 sym = expr->symtree->n.sym;
1259 args = expr->value.function.actual;
1260 gfc_init_se (&lse, NULL);
1261 gfc_init_se (&rse, NULL);
1264 for (fargs = sym->formal; fargs; fargs = fargs->next)
1266 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1267 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1269 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1271 /* Each dummy shall be specified, explicitly or implicitly, to be
1273 assert (fargs->sym->attr.dimension == 0);
1276 /* Create a temporary to hold the value. */
1277 type = gfc_typenode_for_spec (&fsym->ts);
1278 temp_vars[n] = gfc_create_var (type, fsym->name);
1280 if (fsym->ts.type == BT_CHARACTER)
1282 /* Copy string arguments. */
1285 assert (fsym->ts.cl && fsym->ts.cl->length
1286 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1288 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1289 tmp = gfc_build_addr_expr (build_pointer_type (type),
1292 gfc_conv_expr (&rse, args->expr);
1293 gfc_conv_string_parameter (&rse);
1294 gfc_add_block_to_block (&se->pre, &lse.pre);
1295 gfc_add_block_to_block (&se->pre, &rse.pre);
1297 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1299 gfc_add_block_to_block (&se->pre, &lse.post);
1300 gfc_add_block_to_block (&se->pre, &rse.post);
1304 /* For everything else, just evaluate the expression. */
1305 gfc_conv_expr (&lse, args->expr);
1307 gfc_add_block_to_block (&se->pre, &lse.pre);
1308 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1309 gfc_add_block_to_block (&se->pre, &lse.post);
1315 /* Use the temporary variables in place of the real ones. */
1316 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1317 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1319 gfc_conv_expr (se, sym->value);
1321 if (sym->ts.type == BT_CHARACTER)
1323 gfc_conv_const_charlen (sym->ts.cl);
1325 /* Force the expression to the correct length. */
1326 if (!INTEGER_CST_P (se->string_length)
1327 || tree_int_cst_lt (se->string_length,
1328 sym->ts.cl->backend_decl))
1330 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1331 tmp = gfc_create_var (type, sym->name);
1332 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1333 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1334 se->string_length, se->expr);
1337 se->string_length = sym->ts.cl->backend_decl;
1340 /* Restore the original variables. */
1341 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1342 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1343 gfc_free (saved_vars);
1347 /* Translate a function expression. */
1350 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1354 if (expr->value.function.isym)
1356 gfc_conv_intrinsic_function (se, expr);
1360 /* We distinguish statement functions from general functions to improve
1361 runtime performance. */
1362 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1364 gfc_conv_statement_function (se, expr);
1368 /* expr.value.function.esym is the resolved (specific) function symbol for
1369 most functions. However this isn't set for dummy procedures. */
1370 sym = expr->value.function.esym;
1372 sym = expr->symtree->n.sym;
1373 gfc_conv_function_call (se, sym, expr->value.function.actual);
1378 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1380 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1381 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1383 gfc_conv_tmp_array_ref (se);
1384 gfc_advance_se_ss_chain (se);
1388 /* Build a static initializer. EXPR is the expression for the initial value.
1389 The other parameters describe the variable of the component being
1390 initialized. EXPR may be null. */
1393 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1394 bool array, bool pointer)
1398 if (!(expr || pointer))
1403 /* Arrays need special handling. */
1405 return gfc_build_null_descriptor (type);
1407 return gfc_conv_array_initializer (type, expr);
1410 return fold_convert (type, null_pointer_node);
1416 gfc_init_se (&se, NULL);
1417 gfc_conv_structure (&se, expr, 1);
1421 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1424 gfc_init_se (&se, NULL);
1425 gfc_conv_constant (&se, expr);
1432 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1444 gfc_start_block (&block);
1446 /* Initialize the scalarizer. */
1447 gfc_init_loopinfo (&loop);
1449 gfc_init_se (&lse, NULL);
1450 gfc_init_se (&rse, NULL);
1453 rss = gfc_walk_expr (expr);
1454 if (rss == gfc_ss_terminator)
1456 /* The rhs is scalar. Add a ss for the expression. */
1457 rss = gfc_get_ss ();
1458 rss->next = gfc_ss_terminator;
1459 rss->type = GFC_SS_SCALAR;
1463 /* Create a SS for the destination. */
1464 lss = gfc_get_ss ();
1465 lss->type = GFC_SS_COMPONENT;
1467 lss->shape = gfc_get_shape (cm->as->rank);
1468 lss->next = gfc_ss_terminator;
1469 lss->data.info.dimen = cm->as->rank;
1470 lss->data.info.descriptor = dest;
1471 lss->data.info.data = gfc_conv_array_data (dest);
1472 lss->data.info.offset = gfc_conv_array_offset (dest);
1473 for (n = 0; n < cm->as->rank; n++)
1475 lss->data.info.dim[n] = n;
1476 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1477 lss->data.info.stride[n] = gfc_index_one_node;
1479 mpz_init (lss->shape[n]);
1480 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1481 cm->as->lower[n]->value.integer);
1482 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1485 /* Associate the SS with the loop. */
1486 gfc_add_ss_to_loop (&loop, lss);
1487 gfc_add_ss_to_loop (&loop, rss);
1489 /* Calculate the bounds of the scalarization. */
1490 gfc_conv_ss_startstride (&loop);
1492 /* Setup the scalarizing loops. */
1493 gfc_conv_loop_setup (&loop);
1495 /* Setup the gfc_se structures. */
1496 gfc_copy_loopinfo_to_se (&lse, &loop);
1497 gfc_copy_loopinfo_to_se (&rse, &loop);
1500 gfc_mark_ss_chain_used (rss, 1);
1502 gfc_mark_ss_chain_used (lss, 1);
1504 /* Start the scalarized loop body. */
1505 gfc_start_scalarized_body (&loop, &body);
1507 gfc_conv_tmp_array_ref (&lse);
1508 gfc_conv_expr (&rse, expr);
1510 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1511 gfc_add_expr_to_block (&body, tmp);
1513 if (rse.ss != gfc_ss_terminator)
1516 /* Generate the copying loops. */
1517 gfc_trans_scalarizing_loops (&loop, &body);
1519 /* Wrap the whole thing up. */
1520 gfc_add_block_to_block (&block, &loop.pre);
1521 gfc_add_block_to_block (&block, &loop.post);
1523 gfc_cleanup_loop (&loop);
1525 for (n = 0; n < cm->as->rank; n++)
1526 mpz_clear (lss->shape[n]);
1527 gfc_free (lss->shape);
1529 return gfc_finish_block (&block);
1532 /* Assign a single component of a derived type constructor. */
1535 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1542 gfc_start_block (&block);
1545 gfc_init_se (&se, NULL);
1546 /* Pointer component. */
1549 /* Array pointer. */
1550 if (expr->expr_type == EXPR_NULL)
1552 dest = gfc_conv_descriptor_data (dest);
1553 tmp = fold_convert (TREE_TYPE (se.expr),
1555 gfc_add_modify_expr (&block, dest, tmp);
1559 rss = gfc_walk_expr (expr);
1560 se.direct_byref = 1;
1562 gfc_conv_expr_descriptor (&se, expr, rss);
1563 gfc_add_block_to_block (&block, &se.pre);
1564 gfc_add_block_to_block (&block, &se.post);
1569 /* Scalar pointers. */
1570 se.want_pointer = 1;
1571 gfc_conv_expr (&se, expr);
1572 gfc_add_block_to_block (&block, &se.pre);
1573 gfc_add_modify_expr (&block, dest,
1574 fold_convert (TREE_TYPE (dest), se.expr));
1575 gfc_add_block_to_block (&block, &se.post);
1578 else if (cm->dimension)
1580 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1581 gfc_add_expr_to_block (&block, tmp);
1583 else if (expr->ts.type == BT_DERIVED)
1585 /* Nested dervived type. */
1586 tmp = gfc_trans_structure_assign (dest, expr);
1587 gfc_add_expr_to_block (&block, tmp);
1591 /* Scalar component. */
1594 gfc_init_se (&se, NULL);
1595 gfc_init_se (&lse, NULL);
1597 gfc_conv_expr (&se, expr);
1598 if (cm->ts.type == BT_CHARACTER)
1599 lse.string_length = cm->ts.cl->backend_decl;
1601 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1602 gfc_add_expr_to_block (&block, tmp);
1604 return gfc_finish_block (&block);
1607 /* Assign a derived type contructor to a variable. */
1610 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1618 gfc_start_block (&block);
1619 cm = expr->ts.derived->components;
1620 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1622 /* Skip absent members in default initializers. */
1626 field = cm->backend_decl;
1627 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1628 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1629 gfc_add_expr_to_block (&block, tmp);
1631 return gfc_finish_block (&block);
1634 /* Build an expression for a constructor. If init is nonzero then
1635 this is part of a static variable initializer. */
1638 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1648 assert (se->ss == NULL);
1649 assert (expr->expr_type == EXPR_STRUCTURE);
1650 type = gfc_typenode_for_spec (&expr->ts);
1654 /* Create a temporary variable and fill it in. */
1655 se->expr = gfc_create_var (type, expr->ts.derived->name);
1656 tmp = gfc_trans_structure_assign (se->expr, expr);
1657 gfc_add_expr_to_block (&se->pre, tmp);
1661 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1664 cm = expr->ts.derived->components;
1665 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1667 /* Skip absent members in default initializers. */
1671 val = gfc_conv_initializer (c->expr, &cm->ts,
1672 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1674 /* Build a TREE_CHAIN to hold it. */
1675 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1677 /* Add it to the list. */
1678 if (tail == NULL_TREE)
1679 TREE_OPERAND(head, 0) = tail = val;
1682 TREE_CHAIN (tail) = val;
1690 /* Translate a substring expression. */
1693 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1699 assert(ref->type == REF_SUBSTRING);
1701 se->expr = gfc_build_string_const(expr->value.character.length,
1702 expr->value.character.string);
1703 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1704 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1706 gfc_conv_substring(se,ref,expr->ts.kind);
1710 /* Entry point for expression translation. */
1713 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1715 if (se->ss && se->ss->expr == expr
1716 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1718 /* Substitute a scalar expression evaluated outside the scalarization
1720 se->expr = se->ss->data.scalar.expr;
1721 se->string_length = se->ss->string_length;
1722 gfc_advance_se_ss_chain (se);
1726 switch (expr->expr_type)
1729 gfc_conv_expr_op (se, expr);
1733 gfc_conv_function_expr (se, expr);
1737 gfc_conv_constant (se, expr);
1741 gfc_conv_variable (se, expr);
1745 se->expr = null_pointer_node;
1748 case EXPR_SUBSTRING:
1749 gfc_conv_substring_expr (se, expr);
1752 case EXPR_STRUCTURE:
1753 gfc_conv_structure (se, expr, 0);
1757 gfc_conv_array_constructor_expr (se, expr);
1767 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1769 gfc_conv_expr (se, expr);
1770 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1771 figure out a way of rewriting an lvalue so that it has no post chain. */
1772 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1776 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1780 assert (expr->ts.type != BT_CHARACTER);
1781 gfc_conv_expr (se, expr);
1784 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1785 gfc_add_modify_expr (&se->pre, val, se->expr);
1790 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1792 gfc_conv_expr_val (se, expr);
1793 se->expr = convert (type, se->expr);
1797 /* Converts an expression so that it can be passed by reference. Scalar
1801 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1805 if (se->ss && se->ss->expr == expr
1806 && se->ss->type == GFC_SS_REFERENCE)
1808 se->expr = se->ss->data.scalar.expr;
1809 se->string_length = se->ss->string_length;
1810 gfc_advance_se_ss_chain (se);
1814 if (expr->ts.type == BT_CHARACTER)
1816 gfc_conv_expr (se, expr);
1817 gfc_conv_string_parameter (se);
1821 if (expr->expr_type == EXPR_VARIABLE)
1823 se->want_pointer = 1;
1824 gfc_conv_expr (se, expr);
1827 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1828 gfc_add_modify_expr (&se->pre, var, se->expr);
1829 gfc_add_block_to_block (&se->pre, &se->post);
1835 gfc_conv_expr (se, expr);
1837 /* Create a temporary var to hold the value. */
1838 if (TREE_CONSTANT (se->expr))
1840 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1841 DECL_INITIAL (var) = se->expr;
1846 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1847 gfc_add_modify_expr (&se->pre, var, se->expr);
1849 gfc_add_block_to_block (&se->pre, &se->post);
1851 /* Take the address of that value. */
1852 se->expr = gfc_build_addr_expr (NULL, var);
1857 gfc_trans_pointer_assign (gfc_code * code)
1859 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1863 /* Generate code for a pointer assignment. */
1866 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1874 gfc_start_block (&block);
1876 gfc_init_se (&lse, NULL);
1878 lss = gfc_walk_expr (expr1);
1879 rss = gfc_walk_expr (expr2);
1880 if (lss == gfc_ss_terminator)
1882 /* Scalar pointers. */
1883 lse.want_pointer = 1;
1884 gfc_conv_expr (&lse, expr1);
1885 assert (rss == gfc_ss_terminator);
1886 gfc_init_se (&rse, NULL);
1887 rse.want_pointer = 1;
1888 gfc_conv_expr (&rse, expr2);
1889 gfc_add_block_to_block (&block, &lse.pre);
1890 gfc_add_block_to_block (&block, &rse.pre);
1891 gfc_add_modify_expr (&block, lse.expr,
1892 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1893 gfc_add_block_to_block (&block, &rse.post);
1894 gfc_add_block_to_block (&block, &lse.post);
1898 /* Array pointer. */
1899 gfc_conv_expr_descriptor (&lse, expr1, lss);
1900 /* Implement Nullify. */
1901 if (expr2->expr_type == EXPR_NULL)
1903 lse.expr = gfc_conv_descriptor_data (lse.expr);
1904 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1905 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1909 lse.direct_byref = 1;
1910 gfc_conv_expr_descriptor (&lse, expr2, rss);
1912 gfc_add_block_to_block (&block, &lse.pre);
1913 gfc_add_block_to_block (&block, &lse.post);
1915 return gfc_finish_block (&block);
1919 /* Makes sure se is suitable for passing as a function string parameter. */
1920 /* TODO: Need to check all callers fo this function. It may be abused. */
1923 gfc_conv_string_parameter (gfc_se * se)
1927 if (TREE_CODE (se->expr) == STRING_CST)
1929 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1933 type = TREE_TYPE (se->expr);
1934 if (TYPE_STRING_FLAG (type))
1936 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1937 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1940 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1941 assert (se->string_length
1942 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1946 /* Generate code for assignment of scalar variables. Includes character
1950 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1954 gfc_init_block (&block);
1956 if (type == BT_CHARACTER)
1958 assert (lse->string_length != NULL_TREE
1959 && rse->string_length != NULL_TREE);
1961 gfc_conv_string_parameter (lse);
1962 gfc_conv_string_parameter (rse);
1964 gfc_add_block_to_block (&block, &lse->pre);
1965 gfc_add_block_to_block (&block, &rse->pre);
1967 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1968 rse->string_length, rse->expr);
1972 gfc_add_block_to_block (&block, &lse->pre);
1973 gfc_add_block_to_block (&block, &rse->pre);
1975 gfc_add_modify_expr (&block, lse->expr,
1976 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1979 gfc_add_block_to_block (&block, &lse->post);
1980 gfc_add_block_to_block (&block, &rse->post);
1982 return gfc_finish_block (&block);
1986 /* Try to translate array(:) = func (...), where func is a transformational
1987 array function, without using a temporary. Returns NULL is this isn't the
1991 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1996 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1997 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2000 /* Elemental functions don't need a temporary anyway. */
2001 if (expr2->symtree->n.sym->attr.elemental)
2004 /* Check for a dependency. */
2005 if (gfc_check_fncall_dependency (expr1, expr2))
2008 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2010 assert (expr2->value.function.isym
2011 || (gfc_return_by_reference (expr2->symtree->n.sym)
2012 && expr2->symtree->n.sym->result->attr.dimension));
2014 ss = gfc_walk_expr (expr1);
2015 assert (ss != gfc_ss_terminator);
2016 gfc_init_se (&se, NULL);
2017 gfc_start_block (&se.pre);
2018 se.want_pointer = 1;
2020 gfc_conv_array_parameter (&se, expr1, ss, 0);
2022 se.direct_byref = 1;
2023 se.ss = gfc_walk_expr (expr2);
2024 assert (se.ss != gfc_ss_terminator);
2025 gfc_conv_function_expr (&se, expr2);
2026 gfc_add_block_to_block (&se.pre, &se.post);
2028 return gfc_finish_block (&se.pre);
2032 /* Translate an assignment. Most of the code is concerned with
2033 setting up the scalarizer. */
2036 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2041 gfc_ss *lss_section;
2048 /* Special case a single function returning an array. */
2049 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2051 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2056 /* Assignment of the form lhs = rhs. */
2057 gfc_start_block (&block);
2059 gfc_init_se (&lse, NULL);
2060 gfc_init_se (&rse, NULL);
2063 lss = gfc_walk_expr (expr1);
2065 if (lss != gfc_ss_terminator)
2067 /* The assignment needs scalarization. */
2070 /* Find a non-scalar SS from the lhs. */
2071 while (lss_section != gfc_ss_terminator
2072 && lss_section->type != GFC_SS_SECTION)
2073 lss_section = lss_section->next;
2075 assert (lss_section != gfc_ss_terminator);
2077 /* Initialize the scalarizer. */
2078 gfc_init_loopinfo (&loop);
2081 rss = gfc_walk_expr (expr2);
2082 if (rss == gfc_ss_terminator)
2084 /* The rhs is scalar. Add a ss for the expression. */
2085 rss = gfc_get_ss ();
2086 rss->next = gfc_ss_terminator;
2087 rss->type = GFC_SS_SCALAR;
2090 /* Associate the SS with the loop. */
2091 gfc_add_ss_to_loop (&loop, lss);
2092 gfc_add_ss_to_loop (&loop, rss);
2094 /* Calculate the bounds of the scalarization. */
2095 gfc_conv_ss_startstride (&loop);
2096 /* Resolve any data dependencies in the statement. */
2097 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2098 /* Setup the scalarizing loops. */
2099 gfc_conv_loop_setup (&loop);
2101 /* Setup the gfc_se structures. */
2102 gfc_copy_loopinfo_to_se (&lse, &loop);
2103 gfc_copy_loopinfo_to_se (&rse, &loop);
2106 gfc_mark_ss_chain_used (rss, 1);
2107 if (loop.temp_ss == NULL)
2110 gfc_mark_ss_chain_used (lss, 1);
2114 lse.ss = loop.temp_ss;
2115 gfc_mark_ss_chain_used (lss, 3);
2116 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2119 /* Start the scalarized loop body. */
2120 gfc_start_scalarized_body (&loop, &body);
2123 gfc_init_block (&body);
2125 /* Translate the expression. */
2126 gfc_conv_expr (&rse, expr2);
2128 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2130 gfc_conv_tmp_array_ref (&lse);
2131 gfc_advance_se_ss_chain (&lse);
2134 gfc_conv_expr (&lse, expr1);
2136 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2137 gfc_add_expr_to_block (&body, tmp);
2139 if (lss == gfc_ss_terminator)
2141 /* Use the scalar assignment as is. */
2142 gfc_add_block_to_block (&block, &body);
2146 if (lse.ss != gfc_ss_terminator)
2148 if (rse.ss != gfc_ss_terminator)
2151 if (loop.temp_ss != NULL)
2153 gfc_trans_scalarized_loop_boundary (&loop, &body);
2155 /* We need to copy the temporary to the actual lhs. */
2156 gfc_init_se (&lse, NULL);
2157 gfc_init_se (&rse, NULL);
2158 gfc_copy_loopinfo_to_se (&lse, &loop);
2159 gfc_copy_loopinfo_to_se (&rse, &loop);
2161 rse.ss = loop.temp_ss;
2164 gfc_conv_tmp_array_ref (&rse);
2165 gfc_advance_se_ss_chain (&rse);
2166 gfc_conv_expr (&lse, expr1);
2168 if (lse.ss != gfc_ss_terminator)
2171 if (rse.ss != gfc_ss_terminator)
2174 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2175 gfc_add_expr_to_block (&body, tmp);
2177 /* Generate the copying loops. */
2178 gfc_trans_scalarizing_loops (&loop, &body);
2180 /* Wrap the whole thing up. */
2181 gfc_add_block_to_block (&block, &loop.pre);
2182 gfc_add_block_to_block (&block, &loop.post);
2184 gfc_cleanup_loop (&loop);
2187 return gfc_finish_block (&block);
2191 gfc_trans_assign (gfc_code * code)
2193 return gfc_trans_assignment (code->expr, code->expr2);