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)
556 tree gfc_int4_type_node;
564 gfc_init_se (&lse, se);
565 gfc_conv_expr_val (&lse, expr->op1);
566 gfc_add_block_to_block (&se->pre, &lse.pre);
568 gfc_init_se (&rse, se);
569 gfc_conv_expr_val (&rse, expr->op2);
570 gfc_add_block_to_block (&se->pre, &rse.pre);
572 if (expr->op2->ts.type == BT_INTEGER
573 && expr->op2->expr_type == EXPR_CONSTANT)
574 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
577 gfc_int4_type_node = gfc_get_int_type (4);
579 kind = expr->op1->ts.kind;
580 switch (expr->op2->ts.type)
583 ikind = expr->op2->ts.kind;
588 rse.expr = convert (gfc_int4_type_node, rse.expr);
606 if (expr->op1->ts.type == BT_INTEGER)
607 lse.expr = convert (gfc_int4_type_node, lse.expr);
624 switch (expr->op1->ts.type)
627 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
631 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
635 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
647 fndecl = built_in_decls[BUILT_IN_POWF];
650 fndecl = built_in_decls[BUILT_IN_POW];
661 fndecl = gfor_fndecl_math_cpowf;
664 fndecl = gfor_fndecl_math_cpow;
676 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
677 tmp = gfc_chainon_list (tmp, rse.expr);
678 se->expr = fold (gfc_build_function_call (fndecl, tmp));
682 /* Generate code to allocate a string temporary. */
685 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
691 if (TREE_TYPE (len) != gfc_strlen_type_node)
694 if (gfc_can_put_var_on_stack (len))
696 /* Create a temporary variable to hold the result. */
697 tmp = fold (build2 (MINUS_EXPR, gfc_strlen_type_node, len,
698 convert (gfc_strlen_type_node,
700 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
701 tmp = build_array_type (gfc_character1_type_node, tmp);
702 var = gfc_create_var (tmp, "str");
703 var = gfc_build_addr_expr (type, var);
707 /* Allocate a temporary to hold the result. */
708 var = gfc_create_var (type, "pstr");
709 args = gfc_chainon_list (NULL_TREE, len);
710 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
711 tmp = convert (type, tmp);
712 gfc_add_modify_expr (&se->pre, var, tmp);
714 /* Free the temporary afterwards. */
715 tmp = convert (pvoid_type_node, var);
716 args = gfc_chainon_list (NULL_TREE, tmp);
717 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
718 gfc_add_expr_to_block (&se->post, tmp);
725 /* Handle a string concatenation operation. A temporary will be allocated to
729 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
739 assert (expr->op1->ts.type == BT_CHARACTER
740 && expr->op2->ts.type == BT_CHARACTER);
742 gfc_init_se (&lse, se);
743 gfc_conv_expr (&lse, expr->op1);
744 gfc_conv_string_parameter (&lse);
745 gfc_init_se (&rse, se);
746 gfc_conv_expr (&rse, expr->op2);
747 gfc_conv_string_parameter (&rse);
749 gfc_add_block_to_block (&se->pre, &lse.pre);
750 gfc_add_block_to_block (&se->pre, &rse.pre);
752 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
753 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
754 if (len == NULL_TREE)
756 len = fold (build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
757 lse.string_length, rse.string_length));
760 type = build_pointer_type (type);
762 var = gfc_conv_string_tmp (se, type, len);
764 /* Do the actual concatenation. */
766 args = gfc_chainon_list (args, len);
767 args = gfc_chainon_list (args, var);
768 args = gfc_chainon_list (args, lse.string_length);
769 args = gfc_chainon_list (args, lse.expr);
770 args = gfc_chainon_list (args, rse.string_length);
771 args = gfc_chainon_list (args, rse.expr);
772 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
773 gfc_add_expr_to_block (&se->pre, tmp);
775 /* Add the cleanup for the operands. */
776 gfc_add_block_to_block (&se->pre, &rse.post);
777 gfc_add_block_to_block (&se->pre, &lse.post);
780 se->string_length = len;
784 /* Translates an op expression. Common (binary) cases are handled by this
785 function, others are passed on. Recursion is used in either case.
786 We use the fact that (op1.ts == op2.ts) (except for the power
788 Operators need no special handling for scalarized expressions as long as
789 they call gfc_conv_simple_val to get their operands.
790 Character strings get special handling. */
793 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
805 switch (expr->operator)
807 case INTRINSIC_UPLUS:
808 gfc_conv_expr (se, expr->op1);
811 case INTRINSIC_UMINUS:
812 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
816 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
823 case INTRINSIC_MINUS:
827 case INTRINSIC_TIMES:
831 case INTRINSIC_DIVIDE:
832 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
833 an integer, we must round towards zero, so we use a
835 if (expr->ts.type == BT_INTEGER)
836 code = TRUNC_DIV_EXPR;
841 case INTRINSIC_POWER:
842 gfc_conv_power_op (se, expr);
845 case INTRINSIC_CONCAT:
846 gfc_conv_concat_op (se, expr);
850 code = TRUTH_ANDIF_EXPR;
855 code = TRUTH_ORIF_EXPR;
859 /* EQV and NEQV only work on logicals, but since we represent them
860 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
900 case INTRINSIC_ASSIGN:
901 /* These should be converted into function calls by the frontend. */
906 fatal_error ("Unknown intrinsic op");
910 /* The only exception to this is **, which is handled separately anyway. */
911 assert (expr->op1->ts.type == expr->op2->ts.type);
913 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
917 gfc_init_se (&lse, se);
918 gfc_conv_expr (&lse, expr->op1);
919 gfc_add_block_to_block (&se->pre, &lse.pre);
922 gfc_init_se (&rse, se);
923 gfc_conv_expr (&rse, expr->op2);
924 gfc_add_block_to_block (&se->pre, &rse.pre);
926 /* For string comparisons we generate a library call, and compare the return
930 gfc_conv_string_parameter (&lse);
931 gfc_conv_string_parameter (&rse);
933 tmp = gfc_chainon_list (tmp, lse.string_length);
934 tmp = gfc_chainon_list (tmp, lse.expr);
935 tmp = gfc_chainon_list (tmp, rse.string_length);
936 tmp = gfc_chainon_list (tmp, rse.expr);
938 /* Build a call for the comparison. */
939 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
940 gfc_add_block_to_block (&lse.post, &rse.post);
942 rse.expr = integer_zero_node;
945 type = gfc_typenode_for_spec (&expr->ts);
949 /* The result of logical ops is always boolean_type_node. */
950 tmp = fold (build2 (code, type, lse.expr, rse.expr));
951 se->expr = convert (type, tmp);
954 se->expr = fold (build2 (code, type, lse.expr, rse.expr));
956 /* Add the post blocks. */
957 gfc_add_block_to_block (&se->post, &rse.post);
958 gfc_add_block_to_block (&se->post, &lse.post);
963 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
969 tmp = gfc_get_symbol_decl (sym);
970 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
971 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
977 if (!sym->backend_decl)
978 sym->backend_decl = gfc_get_extern_function_decl (sym);
980 tmp = sym->backend_decl;
981 assert (TREE_CODE (tmp) == FUNCTION_DECL);
982 se->expr = gfc_build_addr_expr (NULL, tmp);
987 /* Generate code for a procedure call. Note can return se->post != NULL.
988 If se->direct_byref is set then se->expr contains the return parameter. */
991 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
992 gfc_actual_arglist * arg)
1005 gfc_formal_arglist *formal;
1007 arglist = NULL_TREE;
1008 stringargs = NULL_TREE;
1014 if (!sym->attr.elemental)
1016 assert (se->ss->type == GFC_SS_FUNCTION);
1017 if (se->ss->useflags)
1019 assert (gfc_return_by_reference (sym)
1020 && sym->result->attr.dimension);
1021 assert (se->loop != NULL);
1023 /* Access the previously obtained result. */
1024 gfc_conv_tmp_array_ref (se);
1025 gfc_advance_se_ss_chain (se);
1029 info = &se->ss->data.info;
1034 byref = gfc_return_by_reference (sym);
1037 if (se->direct_byref)
1038 arglist = gfc_chainon_list (arglist, se->expr);
1039 else if (sym->result->attr.dimension)
1041 assert (se->loop && se->ss);
1042 /* Set the type of the array. */
1043 tmp = gfc_typenode_for_spec (&sym->ts);
1044 info->dimen = se->loop->dimen;
1045 /* Allocate a temporary to store the result. */
1046 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1048 /* Zero the first stride to indicate a temporary. */
1050 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1051 gfc_add_modify_expr (&se->pre, tmp,
1052 convert (TREE_TYPE (tmp), integer_zero_node));
1053 /* Pass the temporary as the first argument. */
1054 tmp = info->descriptor;
1055 tmp = gfc_build_addr_expr (NULL, tmp);
1056 arglist = gfc_chainon_list (arglist, tmp);
1058 else if (sym->ts.type == BT_CHARACTER)
1060 assert (sym->ts.cl && sym->ts.cl->length
1061 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1062 len = gfc_conv_mpz_to_tree
1063 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1064 sym->ts.cl->backend_decl = len;
1065 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1066 type = build_pointer_type (type);
1068 var = gfc_conv_string_tmp (se, type, len);
1069 arglist = gfc_chainon_list (arglist, var);
1070 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1073 else /* TODO: derived type function return values. */
1077 formal = sym->formal;
1078 /* Evaluate the arguments. */
1079 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1081 if (arg->expr == NULL)
1084 if (se->ignore_optional)
1086 /* Some intrinsics have already been resolved to the correct
1090 else if (arg->label)
1092 has_alternate_specifier = 1;
1097 /* Pass a NULL pointer for an absent arg. */
1098 gfc_init_se (&parmse, NULL);
1099 parmse.expr = null_pointer_node;
1100 if (arg->missing_arg_type == BT_CHARACTER)
1103 gfc_chainon_list (stringargs,
1104 convert (gfc_strlen_type_node,
1105 integer_zero_node));
1109 else if (se->ss && se->ss->useflags)
1111 /* An elemental function inside a scalarized loop. */
1112 gfc_init_se (&parmse, se);
1113 gfc_conv_expr_reference (&parmse, arg->expr);
1117 /* A scalar or transformational function. */
1118 gfc_init_se (&parmse, NULL);
1119 argss = gfc_walk_expr (arg->expr);
1121 if (argss == gfc_ss_terminator)
1123 gfc_conv_expr_reference (&parmse, arg->expr);
1124 if (formal && formal->sym->attr.pointer
1125 && arg->expr->expr_type != EXPR_NULL)
1127 /* Scalar pointer dummy args require an extra level of
1128 indirection. The null pointer already contains
1129 this level of indirection. */
1130 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1135 /* If the procedure requires an explicit interface, the
1136 actual argument is passed according to the
1137 corresponding formal argument. If the corresponding
1138 formal argument is a POINTER or assumed shape, we do
1139 not use g77's calling aonvention, and pass the
1140 address of the array descriptor instead. Otherwise we
1141 use g77's calling convention. */
1143 f = (formal != NULL)
1144 && !formal->sym->attr.pointer
1145 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1146 f = f || !sym->attr.always_explicit;
1147 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1151 gfc_add_block_to_block (&se->pre, &parmse.pre);
1152 gfc_add_block_to_block (&se->post, &parmse.post);
1154 /* Character strings are passed as two paramarers, a length and a
1156 if (parmse.string_length != NULL_TREE)
1157 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1159 arglist = gfc_chainon_list (arglist, parmse.expr);
1162 /* Add the hidden string length parameters to the arguments. */
1163 arglist = chainon (arglist, stringargs);
1165 /* Generate the actual call. */
1166 gfc_conv_function_val (se, sym);
1167 /* If there are alternate return labels, function type should be
1169 if (has_alternate_specifier)
1170 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1172 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1173 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1174 arglist, NULL_TREE);
1176 /* If we have a pointer function, but we don't want a pointer, e.g.
1179 where f is pointer valued, we have to dereference the result. */
1180 if (sym->attr.pointer && !se->want_pointer && !byref)
1181 se->expr = gfc_build_indirect_ref (se->expr);
1183 /* A pure function may still have side-effects - it may modify its
1185 TREE_SIDE_EFFECTS (se->expr) = 1;
1187 if (!sym->attr.pure)
1188 TREE_SIDE_EFFECTS (se->expr) = 1;
1193 /* Add the function call to the pre chain. There is no expression. */
1194 gfc_add_expr_to_block (&se->pre, se->expr);
1195 se->expr = NULL_TREE;
1197 if (!se->direct_byref)
1199 if (sym->result->attr.dimension)
1201 if (flag_bounds_check)
1203 /* Check the data pointer hasn't been modified. This would
1204 happen in a function returning a pointer. */
1205 tmp = gfc_conv_descriptor_data (info->descriptor);
1206 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1207 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1209 se->expr = info->descriptor;
1211 else if (sym->ts.type == BT_CHARACTER)
1214 se->string_length = len;
1223 /* Generate code to copy a string. */
1226 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1227 tree slen, tree src)
1232 tmp = gfc_chainon_list (tmp, dlen);
1233 tmp = gfc_chainon_list (tmp, dest);
1234 tmp = gfc_chainon_list (tmp, slen);
1235 tmp = gfc_chainon_list (tmp, src);
1236 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1237 gfc_add_expr_to_block (block, tmp);
1241 /* Translate a statement function.
1242 The value of a statement function reference is obtained by evaluating the
1243 expression using the values of the actual arguments for the values of the
1244 corresponding dummy arguments. */
1247 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1251 gfc_formal_arglist *fargs;
1252 gfc_actual_arglist *args;
1255 gfc_saved_var *saved_vars;
1261 sym = expr->symtree->n.sym;
1262 args = expr->value.function.actual;
1263 gfc_init_se (&lse, NULL);
1264 gfc_init_se (&rse, NULL);
1267 for (fargs = sym->formal; fargs; fargs = fargs->next)
1269 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1270 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1272 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1274 /* Each dummy shall be specified, explicitly or implicitly, to be
1276 assert (fargs->sym->attr.dimension == 0);
1279 /* Create a temporary to hold the value. */
1280 type = gfc_typenode_for_spec (&fsym->ts);
1281 temp_vars[n] = gfc_create_var (type, fsym->name);
1283 if (fsym->ts.type == BT_CHARACTER)
1285 /* Copy string arguments. */
1288 assert (fsym->ts.cl && fsym->ts.cl->length
1289 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1291 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1292 tmp = gfc_build_addr_expr (build_pointer_type (type),
1295 gfc_conv_expr (&rse, args->expr);
1296 gfc_conv_string_parameter (&rse);
1297 gfc_add_block_to_block (&se->pre, &lse.pre);
1298 gfc_add_block_to_block (&se->pre, &rse.pre);
1300 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1302 gfc_add_block_to_block (&se->pre, &lse.post);
1303 gfc_add_block_to_block (&se->pre, &rse.post);
1307 /* For everything else, just evaluate the expression. */
1308 gfc_conv_expr (&lse, args->expr);
1310 gfc_add_block_to_block (&se->pre, &lse.pre);
1311 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1312 gfc_add_block_to_block (&se->pre, &lse.post);
1318 /* Use the temporary variables in place of the real ones. */
1319 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1320 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1322 gfc_conv_expr (se, sym->value);
1324 if (sym->ts.type == BT_CHARACTER)
1326 gfc_conv_const_charlen (sym->ts.cl);
1328 /* Force the expression to the correct length. */
1329 if (!INTEGER_CST_P (se->string_length)
1330 || tree_int_cst_lt (se->string_length,
1331 sym->ts.cl->backend_decl))
1333 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1334 tmp = gfc_create_var (type, sym->name);
1335 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1336 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1337 se->string_length, se->expr);
1340 se->string_length = sym->ts.cl->backend_decl;
1343 /* Restore the original variables. */
1344 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1345 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1346 gfc_free (saved_vars);
1350 /* Translate a function expression. */
1353 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1357 if (expr->value.function.isym)
1359 gfc_conv_intrinsic_function (se, expr);
1363 /* We distinguish statement functions from general functions to improve
1364 runtime performance. */
1365 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1367 gfc_conv_statement_function (se, expr);
1371 /* expr.value.function.esym is the resolved (specific) function symbol for
1372 most functions. However this isn't set for dummy procedures. */
1373 sym = expr->value.function.esym;
1375 sym = expr->symtree->n.sym;
1376 gfc_conv_function_call (se, sym, expr->value.function.actual);
1381 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1383 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1384 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1386 gfc_conv_tmp_array_ref (se);
1387 gfc_advance_se_ss_chain (se);
1391 /* Build a static initializer. EXPR is the expression for the initial value.
1392 The other parameters describe the variable of the component being
1393 initialized. EXPR may be null. */
1396 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1397 bool array, bool pointer)
1401 if (!(expr || pointer))
1406 /* Arrays need special handling. */
1408 return gfc_build_null_descriptor (type);
1410 return gfc_conv_array_initializer (type, expr);
1413 return fold_convert (type, null_pointer_node);
1419 gfc_init_se (&se, NULL);
1420 gfc_conv_structure (&se, expr, 1);
1424 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1427 gfc_init_se (&se, NULL);
1428 gfc_conv_constant (&se, expr);
1435 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1447 gfc_start_block (&block);
1449 /* Initialize the scalarizer. */
1450 gfc_init_loopinfo (&loop);
1452 gfc_init_se (&lse, NULL);
1453 gfc_init_se (&rse, NULL);
1456 rss = gfc_walk_expr (expr);
1457 if (rss == gfc_ss_terminator)
1459 /* The rhs is scalar. Add a ss for the expression. */
1460 rss = gfc_get_ss ();
1461 rss->next = gfc_ss_terminator;
1462 rss->type = GFC_SS_SCALAR;
1466 /* Create a SS for the destination. */
1467 lss = gfc_get_ss ();
1468 lss->type = GFC_SS_COMPONENT;
1470 lss->shape = gfc_get_shape (cm->as->rank);
1471 lss->next = gfc_ss_terminator;
1472 lss->data.info.dimen = cm->as->rank;
1473 lss->data.info.descriptor = dest;
1474 lss->data.info.data = gfc_conv_array_data (dest);
1475 lss->data.info.offset = gfc_conv_array_offset (dest);
1476 for (n = 0; n < cm->as->rank; n++)
1478 lss->data.info.dim[n] = n;
1479 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1480 lss->data.info.stride[n] = gfc_index_one_node;
1482 mpz_init (lss->shape[n]);
1483 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1484 cm->as->lower[n]->value.integer);
1485 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1488 /* Associate the SS with the loop. */
1489 gfc_add_ss_to_loop (&loop, lss);
1490 gfc_add_ss_to_loop (&loop, rss);
1492 /* Calculate the bounds of the scalarization. */
1493 gfc_conv_ss_startstride (&loop);
1495 /* Setup the scalarizing loops. */
1496 gfc_conv_loop_setup (&loop);
1498 /* Setup the gfc_se structures. */
1499 gfc_copy_loopinfo_to_se (&lse, &loop);
1500 gfc_copy_loopinfo_to_se (&rse, &loop);
1503 gfc_mark_ss_chain_used (rss, 1);
1505 gfc_mark_ss_chain_used (lss, 1);
1507 /* Start the scalarized loop body. */
1508 gfc_start_scalarized_body (&loop, &body);
1510 gfc_conv_tmp_array_ref (&lse);
1511 gfc_conv_expr (&rse, expr);
1513 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1514 gfc_add_expr_to_block (&body, tmp);
1516 if (rse.ss != gfc_ss_terminator)
1519 /* Generate the copying loops. */
1520 gfc_trans_scalarizing_loops (&loop, &body);
1522 /* Wrap the whole thing up. */
1523 gfc_add_block_to_block (&block, &loop.pre);
1524 gfc_add_block_to_block (&block, &loop.post);
1526 gfc_cleanup_loop (&loop);
1528 for (n = 0; n < cm->as->rank; n++)
1529 mpz_clear (lss->shape[n]);
1530 gfc_free (lss->shape);
1532 return gfc_finish_block (&block);
1535 /* Assign a single component of a derived type constructor. */
1538 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1545 gfc_start_block (&block);
1548 gfc_init_se (&se, NULL);
1549 /* Pointer component. */
1552 /* Array pointer. */
1553 if (expr->expr_type == EXPR_NULL)
1555 dest = gfc_conv_descriptor_data (dest);
1556 tmp = fold_convert (TREE_TYPE (se.expr),
1558 gfc_add_modify_expr (&block, dest, tmp);
1562 rss = gfc_walk_expr (expr);
1563 se.direct_byref = 1;
1565 gfc_conv_expr_descriptor (&se, expr, rss);
1566 gfc_add_block_to_block (&block, &se.pre);
1567 gfc_add_block_to_block (&block, &se.post);
1572 /* Scalar pointers. */
1573 se.want_pointer = 1;
1574 gfc_conv_expr (&se, expr);
1575 gfc_add_block_to_block (&block, &se.pre);
1576 gfc_add_modify_expr (&block, dest,
1577 fold_convert (TREE_TYPE (dest), se.expr));
1578 gfc_add_block_to_block (&block, &se.post);
1581 else if (cm->dimension)
1583 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1584 gfc_add_expr_to_block (&block, tmp);
1586 else if (expr->ts.type == BT_DERIVED)
1588 /* Nested dervived type. */
1589 tmp = gfc_trans_structure_assign (dest, expr);
1590 gfc_add_expr_to_block (&block, tmp);
1594 /* Scalar component. */
1597 gfc_init_se (&se, NULL);
1598 gfc_init_se (&lse, NULL);
1600 gfc_conv_expr (&se, expr);
1601 if (cm->ts.type == BT_CHARACTER)
1602 lse.string_length = cm->ts.cl->backend_decl;
1604 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1605 gfc_add_expr_to_block (&block, tmp);
1607 return gfc_finish_block (&block);
1610 /* Assign a derived type contructor to a variable. */
1613 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1621 gfc_start_block (&block);
1622 cm = expr->ts.derived->components;
1623 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1625 /* Skip absent members in default initializers. */
1629 field = cm->backend_decl;
1630 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1631 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1632 gfc_add_expr_to_block (&block, tmp);
1634 return gfc_finish_block (&block);
1637 /* Build an expression for a constructor. If init is nonzero then
1638 this is part of a static variable initializer. */
1641 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1651 assert (se->ss == NULL);
1652 assert (expr->expr_type == EXPR_STRUCTURE);
1653 type = gfc_typenode_for_spec (&expr->ts);
1657 /* Create a temporary variable and fill it in. */
1658 se->expr = gfc_create_var (type, expr->ts.derived->name);
1659 tmp = gfc_trans_structure_assign (se->expr, expr);
1660 gfc_add_expr_to_block (&se->pre, tmp);
1664 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1667 cm = expr->ts.derived->components;
1668 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1670 /* Skip absent members in default initializers. */
1674 val = gfc_conv_initializer (c->expr, &cm->ts,
1675 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1677 /* Build a TREE_CHAIN to hold it. */
1678 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1680 /* Add it to the list. */
1681 if (tail == NULL_TREE)
1682 TREE_OPERAND(head, 0) = tail = val;
1685 TREE_CHAIN (tail) = val;
1693 /* Translate a substring expression. */
1696 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1702 assert(ref->type == REF_SUBSTRING);
1704 se->expr = gfc_build_string_const(expr->value.character.length,
1705 expr->value.character.string);
1706 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1707 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1709 gfc_conv_substring(se,ref,expr->ts.kind);
1713 /* Entry point for expression translation. */
1716 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1718 if (se->ss && se->ss->expr == expr
1719 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1721 /* Substitute a scalar expression evaluated outside the scalarization
1723 se->expr = se->ss->data.scalar.expr;
1724 se->string_length = se->ss->string_length;
1725 gfc_advance_se_ss_chain (se);
1729 switch (expr->expr_type)
1732 gfc_conv_expr_op (se, expr);
1736 gfc_conv_function_expr (se, expr);
1740 gfc_conv_constant (se, expr);
1744 gfc_conv_variable (se, expr);
1748 se->expr = null_pointer_node;
1751 case EXPR_SUBSTRING:
1752 gfc_conv_substring_expr (se, expr);
1755 case EXPR_STRUCTURE:
1756 gfc_conv_structure (se, expr, 0);
1760 gfc_conv_array_constructor_expr (se, expr);
1770 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1772 gfc_conv_expr (se, expr);
1773 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1774 figure out a way of rewriting an lvalue so that it has no post chain. */
1775 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1779 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1783 assert (expr->ts.type != BT_CHARACTER);
1784 gfc_conv_expr (se, expr);
1787 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1788 gfc_add_modify_expr (&se->pre, val, se->expr);
1793 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1795 gfc_conv_expr_val (se, expr);
1796 se->expr = convert (type, se->expr);
1800 /* Converts an expression so that it can be passed by reference. Scalar
1804 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1808 if (se->ss && se->ss->expr == expr
1809 && se->ss->type == GFC_SS_REFERENCE)
1811 se->expr = se->ss->data.scalar.expr;
1812 se->string_length = se->ss->string_length;
1813 gfc_advance_se_ss_chain (se);
1817 if (expr->ts.type == BT_CHARACTER)
1819 gfc_conv_expr (se, expr);
1820 gfc_conv_string_parameter (se);
1824 if (expr->expr_type == EXPR_VARIABLE)
1826 se->want_pointer = 1;
1827 gfc_conv_expr (se, expr);
1830 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1831 gfc_add_modify_expr (&se->pre, var, se->expr);
1832 gfc_add_block_to_block (&se->pre, &se->post);
1838 gfc_conv_expr (se, expr);
1840 /* Create a temporary var to hold the value. */
1841 if (TREE_CONSTANT (se->expr))
1843 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1844 DECL_INITIAL (var) = se->expr;
1849 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1850 gfc_add_modify_expr (&se->pre, var, se->expr);
1852 gfc_add_block_to_block (&se->pre, &se->post);
1854 /* Take the address of that value. */
1855 se->expr = gfc_build_addr_expr (NULL, var);
1860 gfc_trans_pointer_assign (gfc_code * code)
1862 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1866 /* Generate code for a pointer assignment. */
1869 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1877 gfc_start_block (&block);
1879 gfc_init_se (&lse, NULL);
1881 lss = gfc_walk_expr (expr1);
1882 rss = gfc_walk_expr (expr2);
1883 if (lss == gfc_ss_terminator)
1885 /* Scalar pointers. */
1886 lse.want_pointer = 1;
1887 gfc_conv_expr (&lse, expr1);
1888 assert (rss == gfc_ss_terminator);
1889 gfc_init_se (&rse, NULL);
1890 rse.want_pointer = 1;
1891 gfc_conv_expr (&rse, expr2);
1892 gfc_add_block_to_block (&block, &lse.pre);
1893 gfc_add_block_to_block (&block, &rse.pre);
1894 gfc_add_modify_expr (&block, lse.expr,
1895 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1896 gfc_add_block_to_block (&block, &rse.post);
1897 gfc_add_block_to_block (&block, &lse.post);
1901 /* Array pointer. */
1902 gfc_conv_expr_descriptor (&lse, expr1, lss);
1903 /* Implement Nullify. */
1904 if (expr2->expr_type == EXPR_NULL)
1906 lse.expr = gfc_conv_descriptor_data (lse.expr);
1907 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1908 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1912 lse.direct_byref = 1;
1913 gfc_conv_expr_descriptor (&lse, expr2, rss);
1915 gfc_add_block_to_block (&block, &lse.pre);
1916 gfc_add_block_to_block (&block, &lse.post);
1918 return gfc_finish_block (&block);
1922 /* Makes sure se is suitable for passing as a function string parameter. */
1923 /* TODO: Need to check all callers fo this function. It may be abused. */
1926 gfc_conv_string_parameter (gfc_se * se)
1930 if (TREE_CODE (se->expr) == STRING_CST)
1932 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1936 type = TREE_TYPE (se->expr);
1937 if (TYPE_STRING_FLAG (type))
1939 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1940 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1943 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1944 assert (se->string_length
1945 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1949 /* Generate code for assignment of scalar variables. Includes character
1953 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1957 gfc_init_block (&block);
1959 if (type == BT_CHARACTER)
1961 assert (lse->string_length != NULL_TREE
1962 && rse->string_length != NULL_TREE);
1964 gfc_conv_string_parameter (lse);
1965 gfc_conv_string_parameter (rse);
1967 gfc_add_block_to_block (&block, &lse->pre);
1968 gfc_add_block_to_block (&block, &rse->pre);
1970 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1971 rse->string_length, rse->expr);
1975 gfc_add_block_to_block (&block, &lse->pre);
1976 gfc_add_block_to_block (&block, &rse->pre);
1978 gfc_add_modify_expr (&block, lse->expr,
1979 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1982 gfc_add_block_to_block (&block, &lse->post);
1983 gfc_add_block_to_block (&block, &rse->post);
1985 return gfc_finish_block (&block);
1989 /* Try to translate array(:) = func (...), where func is a transformational
1990 array function, without using a temporary. Returns NULL is this isn't the
1994 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1999 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2000 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2003 /* Elemental functions don't need a temporary anyway. */
2004 if (expr2->symtree->n.sym->attr.elemental)
2007 /* Check for a dependency. */
2008 if (gfc_check_fncall_dependency (expr1, expr2))
2011 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2013 assert (expr2->value.function.isym
2014 || (gfc_return_by_reference (expr2->symtree->n.sym)
2015 && expr2->symtree->n.sym->result->attr.dimension));
2017 ss = gfc_walk_expr (expr1);
2018 assert (ss != gfc_ss_terminator);
2019 gfc_init_se (&se, NULL);
2020 gfc_start_block (&se.pre);
2021 se.want_pointer = 1;
2023 gfc_conv_array_parameter (&se, expr1, ss, 0);
2025 se.direct_byref = 1;
2026 se.ss = gfc_walk_expr (expr2);
2027 assert (se.ss != gfc_ss_terminator);
2028 gfc_conv_function_expr (&se, expr2);
2029 gfc_add_block_to_block (&se.pre, &se.post);
2031 return gfc_finish_block (&se.pre);
2035 /* Translate an assignment. Most of the code is concerned with
2036 setting up the scalarizer. */
2039 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2044 gfc_ss *lss_section;
2051 /* Special case a single function returning an array. */
2052 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2054 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2059 /* Assignment of the form lhs = rhs. */
2060 gfc_start_block (&block);
2062 gfc_init_se (&lse, NULL);
2063 gfc_init_se (&rse, NULL);
2066 lss = gfc_walk_expr (expr1);
2068 if (lss != gfc_ss_terminator)
2070 /* The assignment needs scalarization. */
2073 /* Find a non-scalar SS from the lhs. */
2074 while (lss_section != gfc_ss_terminator
2075 && lss_section->type != GFC_SS_SECTION)
2076 lss_section = lss_section->next;
2078 assert (lss_section != gfc_ss_terminator);
2080 /* Initialize the scalarizer. */
2081 gfc_init_loopinfo (&loop);
2084 rss = gfc_walk_expr (expr2);
2085 if (rss == gfc_ss_terminator)
2087 /* The rhs is scalar. Add a ss for the expression. */
2088 rss = gfc_get_ss ();
2089 rss->next = gfc_ss_terminator;
2090 rss->type = GFC_SS_SCALAR;
2093 /* Associate the SS with the loop. */
2094 gfc_add_ss_to_loop (&loop, lss);
2095 gfc_add_ss_to_loop (&loop, rss);
2097 /* Calculate the bounds of the scalarization. */
2098 gfc_conv_ss_startstride (&loop);
2099 /* Resolve any data dependencies in the statement. */
2100 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2101 /* Setup the scalarizing loops. */
2102 gfc_conv_loop_setup (&loop);
2104 /* Setup the gfc_se structures. */
2105 gfc_copy_loopinfo_to_se (&lse, &loop);
2106 gfc_copy_loopinfo_to_se (&rse, &loop);
2109 gfc_mark_ss_chain_used (rss, 1);
2110 if (loop.temp_ss == NULL)
2113 gfc_mark_ss_chain_used (lss, 1);
2117 lse.ss = loop.temp_ss;
2118 gfc_mark_ss_chain_used (lss, 3);
2119 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2122 /* Start the scalarized loop body. */
2123 gfc_start_scalarized_body (&loop, &body);
2126 gfc_init_block (&body);
2128 /* Translate the expression. */
2129 gfc_conv_expr (&rse, expr2);
2131 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2133 gfc_conv_tmp_array_ref (&lse);
2134 gfc_advance_se_ss_chain (&lse);
2137 gfc_conv_expr (&lse, expr1);
2139 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2140 gfc_add_expr_to_block (&body, tmp);
2142 if (lss == gfc_ss_terminator)
2144 /* Use the scalar assignment as is. */
2145 gfc_add_block_to_block (&block, &body);
2149 if (lse.ss != gfc_ss_terminator)
2151 if (rse.ss != gfc_ss_terminator)
2154 if (loop.temp_ss != NULL)
2156 gfc_trans_scalarized_loop_boundary (&loop, &body);
2158 /* We need to copy the temporary to the actual lhs. */
2159 gfc_init_se (&lse, NULL);
2160 gfc_init_se (&rse, NULL);
2161 gfc_copy_loopinfo_to_se (&lse, &loop);
2162 gfc_copy_loopinfo_to_se (&rse, &loop);
2164 rse.ss = loop.temp_ss;
2167 gfc_conv_tmp_array_ref (&rse);
2168 gfc_advance_se_ss_chain (&rse);
2169 gfc_conv_expr (&lse, expr1);
2171 if (lse.ss != gfc_ss_terminator)
2174 if (rse.ss != gfc_ss_terminator)
2177 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2178 gfc_add_expr_to_block (&body, tmp);
2180 /* Generate the copying loops. */
2181 gfc_trans_scalarizing_loops (&loop, &body);
2183 /* Wrap the whole thing up. */
2184 gfc_add_block_to_block (&block, &loop.pre);
2185 gfc_add_block_to_block (&block, &loop.post);
2187 gfc_cleanup_loop (&loop);
2190 return gfc_finish_block (&block);
2194 gfc_trans_assign (gfc_code * code)
2196 return gfc_trans_assignment (code->expr, code->expr2);