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 GNU G95.
8 GNU G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU G95; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "tree-simple.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"
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialise a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parent needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistancy check. */
93 assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (TREE_CODE_CLASS (TREE_CODE (se->expr)) == 'c')
113 /* we need a temporary for this result */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify_expr (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present. */
123 gfc_conv_expr_present (gfc_symbol * sym)
127 assert (sym->attr.dummy && sym->attr.optional);
129 decl = gfc_get_symbol_decl (sym);
130 if (TREE_CODE (decl) != PARM_DECL)
132 /* Array parameters use a temporary descriptor, we want the real
134 assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
135 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
136 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
138 return build (NE_EXPR, boolean_type_node, decl, null_pointer_node);
142 /* Generate code to initialize a string length variable. Returns the
146 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
151 gfc_init_se (&se, NULL);
152 gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
153 gfc_add_block_to_block (pblock, &se.pre);
155 tmp = cl->backend_decl;
156 gfc_add_modify_expr (pblock, tmp, se.expr);
160 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
168 type = gfc_get_character_type (kind, ref->u.ss.length);
169 type = build_pointer_type (type);
172 gfc_init_se (&start, se);
173 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
174 gfc_add_block_to_block (&se->pre, &start.pre);
176 if (integer_onep (start.expr))
178 gfc_conv_string_parameter (se);
182 /* Change the start of the string. */
183 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
186 tmp = gfc_build_indirect_ref (se->expr);
187 tmp = gfc_build_array_ref (tmp, start.expr);
188 se->expr = gfc_build_addr_expr (type, tmp);
191 /* Length = end + 1 - start. */
192 gfc_init_se (&end, se);
193 if (ref->u.ss.end == NULL)
194 end.expr = se->string_length;
197 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
198 gfc_add_block_to_block (&se->pre, &end.pre);
201 build (MINUS_EXPR, gfc_strlen_type_node, integer_one_node, start.expr);
202 tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
203 se->string_length = fold (tmp);
207 /* Convert a derived type component reference. */
210 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
217 c = ref->u.c.component;
219 assert (c->backend_decl);
221 field = c->backend_decl;
222 assert (TREE_CODE (field) == FIELD_DECL);
224 tmp = build (COMPONENT_REF, TREE_TYPE (field), decl, field);
228 if (c->ts.type == BT_CHARACTER)
230 tmp = c->ts.cl->backend_decl;
232 if (!INTEGER_CST_P (tmp))
233 gfc_todo_error ("Unknown length character component");
234 se->string_length = tmp;
237 if (c->pointer && c->dimension == 0)
238 se->expr = gfc_build_indirect_ref (se->expr);
242 /* Return the contents of a variable. Also handles reference/pointer
243 variables (all Fortran pointer references are implicit). */
246 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
251 sym = expr->symtree->n.sym;
254 /* Check that something hasn't gone horribly wrong. */
255 assert (se->ss != gfc_ss_terminator);
256 assert (se->ss->expr == expr);
258 /* A scalarized term. We already know the descriptor. */
259 se->expr = se->ss->data.info.descriptor;
260 ref = se->ss->data.info.ref;
264 se->expr = gfc_get_symbol_decl (sym);
266 /* Procedure actual arguments. */
267 if (sym->attr.flavor == FL_PROCEDURE
268 && se->expr != current_function_decl)
270 assert (se->want_pointer);
271 if (!sym->attr.dummy)
273 assert (TREE_CODE (se->expr) == FUNCTION_DECL);
274 se->expr = gfc_build_addr_expr (NULL, se->expr);
279 /* Special case for assigning the return value of a function.
280 Self recursive functions must have an explicit return value. */
281 if (se->expr == current_function_decl && sym->attr.function
282 && (sym->result == sym))
284 se->expr = gfc_get_fake_result_decl (sym);
287 /* Dereference scalar dummy variables. */
289 && sym->ts.type != BT_CHARACTER
290 && !sym->attr.dimension)
291 se->expr = gfc_build_indirect_ref (se->expr);
293 /* Dereference pointer variables. */
294 if ((sym->attr.pointer || sym->attr.allocatable)
297 || sym->attr.function
298 || !sym->attr.dimension)
299 && sym->ts.type != BT_CHARACTER)
300 se->expr = gfc_build_indirect_ref (se->expr);
305 /* For character variables, also get the length. */
306 if (sym->ts.type == BT_CHARACTER)
308 se->string_length = sym->ts.cl->backend_decl;
309 assert (se->string_length);
317 /* Return the descriptor if that's what we want and this is an array
318 section reference. */
319 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
321 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
322 /* Return the descriptor for array pointers and allocations. */
324 && ref->next == NULL && (se->descriptor_only))
327 gfc_conv_array_ref (se, &ref->u.ar);
328 /* Return a pointer to an element. */
332 gfc_conv_component_ref (se, ref);
336 gfc_conv_substring (se, ref, expr->ts.kind);
345 /* Pointer assignment, allocation or pass by reference. Arrays are handled
347 if (se->want_pointer)
349 if (expr->ts.type == BT_CHARACTER)
350 gfc_conv_string_parameter (se);
352 se->expr = gfc_build_addr_expr (NULL, se->expr);
355 gfc_advance_se_ss_chain (se);
359 /* Unary ops are easy... Or they would be if ! was a valid op. */
362 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
367 assert (expr->ts.type != BT_CHARACTER);
368 /* Initialize the operand. */
369 gfc_init_se (&operand, se);
370 gfc_conv_expr_val (&operand, expr->op1);
371 gfc_add_block_to_block (&se->pre, &operand.pre);
373 type = gfc_typenode_for_spec (&expr->ts);
375 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
376 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
377 All other unary operators have an equivalent SIMPLE unary operator */
378 if (code == TRUTH_NOT_EXPR)
379 se->expr = build (EQ_EXPR, type, operand.expr, integer_zero_node);
381 se->expr = build1 (code, type, operand.expr);
386 /* For power op (lhs ** rhs) We generate:
400 // for constant rhs we do the above at compile time
402 for (n = 1; n < count; n++)
407 gfc_conv_integer_power (gfc_se * se, tree lhs, tree rhs)
420 type = TREE_TYPE (lhs);
422 if (INTEGER_CST_P (rhs))
424 if (integer_zerop (rhs))
426 se->expr = gfc_build_const (type, integer_one_node);
429 /* Special cases for constant values. */
430 if (TREE_INT_CST_HIGH (rhs) == -1)
432 /* x ** (-y) == 1 / (x ** y). */
433 if (TREE_CODE (type) == INTEGER_TYPE)
435 se->expr = integer_zero_node;
439 tmp = gfc_build_const (type, integer_one_node);
440 lhs = fold (build (RDIV_EXPR, type, tmp, lhs));
442 rhs = fold (build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs));
443 assert (INTEGER_CST_P (rhs));
447 /* TODO: really big integer powers. */
448 assert (TREE_INT_CST_HIGH (rhs) == 0);
451 if (integer_onep (rhs))
456 if (TREE_INT_CST_LOW (rhs) == 2)
458 se->expr = build (MULT_EXPR, type, lhs, lhs);
461 if (TREE_INT_CST_LOW (rhs) == 3)
463 tmp = build (MULT_EXPR, type, lhs, lhs);
464 se->expr = fold (build (MULT_EXPR, type, tmp, lhs));
468 /* Create the loop count variable. */
469 count = gfc_create_var (TREE_TYPE (rhs), "count");
470 gfc_add_modify_expr (&se->pre, count, rhs);
474 /* Put the lhs into a temporary variable. */
475 var = gfc_create_var (type, "val");
476 count = gfc_create_var (TREE_TYPE (rhs), "count");
477 gfc_add_modify_expr (&se->pre, var, lhs);
480 /* Generate code for negative rhs. */
481 gfc_start_block (&block);
483 if (TREE_CODE (TREE_TYPE (lhs)) == INTEGER_TYPE)
485 gfc_add_modify_expr (&block, lhs, integer_zero_node);
486 gfc_add_modify_expr (&block, count, integer_zero_node);
490 tmp = gfc_build_const (type, integer_one_node);
491 tmp = build (RDIV_EXPR, type, tmp, lhs);
492 gfc_add_modify_expr (&block, var, tmp);
494 tmp = build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs);
495 gfc_add_modify_expr (&block, count, tmp);
497 neg_stmt = gfc_finish_block (&block);
499 pos_stmt = build_v (MODIFY_EXPR, count, rhs);
501 /* Code for rhs == 0. */
502 gfc_start_block (&block);
504 gfc_add_modify_expr (&block, count, integer_zero_node);
505 tmp = gfc_build_const (type, integer_one_node);
506 gfc_add_modify_expr (&block, lhs, tmp);
508 tmp = gfc_finish_block (&block);
510 /* Select the appropriate action. */
511 cond = build (EQ_EXPR, boolean_type_node, rhs, integer_zero_node);
512 tmp = build_v (COND_EXPR, cond, tmp, neg_stmt);
514 cond = build (GT_EXPR, boolean_type_node, rhs, integer_zero_node);
515 tmp = build_v (COND_EXPR, cond, pos_stmt, tmp);
516 gfc_add_expr_to_block (&se->pre, tmp);
519 /* Create a variable for the result. */
520 result = gfc_create_var (type, "pow");
521 gfc_add_modify_expr (&se->pre, result, lhs);
523 exit_label = gfc_build_label_decl (NULL_TREE);
524 TREE_USED (exit_label) = 1;
526 /* Create the loop body. */
527 gfc_start_block (&block);
529 /* First the exit condition (until count <= 1). */
530 tmp = build1_v (GOTO_EXPR, exit_label);
531 cond = build (LE_EXPR, TREE_TYPE (count), count, integer_one_node);
532 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
533 gfc_add_expr_to_block (&block, tmp);
535 /* Multiply by the lhs. */
536 tmp = build (MULT_EXPR, type, result, lhs);
537 gfc_add_modify_expr (&block, result, tmp);
539 /* Adjust the loop count. */
540 tmp = build (MINUS_EXPR, TREE_TYPE (count), count, integer_one_node);
541 gfc_add_modify_expr (&block, count, tmp);
543 tmp = gfc_finish_block (&block);
545 /* Create the the loop. */
546 tmp = build_v (LOOP_EXPR, tmp);
547 gfc_add_expr_to_block (&se->pre, tmp);
549 /* Add the exit label. */
550 tmp = build1_v (LABEL_EXPR, exit_label);
551 gfc_add_expr_to_block (&se->pre, tmp);
557 /* Power op (**). Integer rhs has special handling. */
560 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
569 gfc_init_se (&lse, se);
570 gfc_conv_expr_val (&lse, expr->op1);
571 gfc_add_block_to_block (&se->pre, &lse.pre);
573 gfc_init_se (&rse, se);
574 gfc_conv_expr_val (&rse, expr->op2);
575 gfc_add_block_to_block (&se->pre, &rse.pre);
577 type = TREE_TYPE (lse.expr);
579 kind = expr->op1->ts.kind;
580 switch (expr->op2->ts.type)
583 /* Integer powers are expanded inline as multiplications. */
584 gfc_conv_integer_power (se, lse.expr, rse.expr);
591 fndecl = gfor_fndecl_math_powf;
594 fndecl = gfor_fndecl_math_pow;
605 fndecl = gfor_fndecl_math_cpowf;
608 fndecl = gfor_fndecl_math_cpow;
620 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
621 tmp = gfc_chainon_list (tmp, rse.expr);
622 se->expr = gfc_build_function_call (fndecl, tmp);
626 /* Generate code to allocate a string temporary. */
629 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
635 if (gfc_can_put_var_on_stack (len))
637 /* Create a temporary variable to hold the result. */
638 tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
639 tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
640 tmp = build_array_type (gfc_character1_type_node, tmp);
641 var = gfc_create_var (tmp, "str");
642 var = gfc_build_addr_expr (type, var);
646 /* Allocate a temporary to hold the result. */
647 var = gfc_create_var (type, "pstr");
648 args = gfc_chainon_list (NULL_TREE, len);
649 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
650 tmp = convert (type, tmp);
651 gfc_add_modify_expr (&se->pre, var, tmp);
653 /* Free the temporary afterwards. */
654 tmp = convert (pvoid_type_node, var);
655 args = gfc_chainon_list (NULL_TREE, tmp);
656 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
657 gfc_add_expr_to_block (&se->post, tmp);
664 /* Handle a string concatenation operation. A temporary will be allocated to
668 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
678 assert (expr->op1->ts.type == BT_CHARACTER
679 && expr->op2->ts.type == BT_CHARACTER);
681 gfc_init_se (&lse, se);
682 gfc_conv_expr (&lse, expr->op1);
683 gfc_conv_string_parameter (&lse);
684 gfc_init_se (&rse, se);
685 gfc_conv_expr (&rse, expr->op2);
686 gfc_conv_string_parameter (&rse);
688 gfc_add_block_to_block (&se->pre, &lse.pre);
689 gfc_add_block_to_block (&se->pre, &rse.pre);
691 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
692 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
693 if (len == NULL_TREE)
695 len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
696 lse.string_length, rse.string_length));
699 type = build_pointer_type (type);
701 var = gfc_conv_string_tmp (se, type, len);
703 /* Do the actual concatenation. */
705 args = gfc_chainon_list (args, len);
706 args = gfc_chainon_list (args, var);
707 args = gfc_chainon_list (args, lse.string_length);
708 args = gfc_chainon_list (args, lse.expr);
709 args = gfc_chainon_list (args, rse.string_length);
710 args = gfc_chainon_list (args, rse.expr);
711 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
712 gfc_add_expr_to_block (&se->pre, tmp);
714 /* Add the cleanup for the operands. */
715 gfc_add_block_to_block (&se->pre, &rse.post);
716 gfc_add_block_to_block (&se->pre, &lse.post);
719 se->string_length = len;
723 /* Translates an op expression. Common (binary) cases are handled by this
724 function, others are passed on. Recursion is used in either case.
725 We use the fact that (op1.ts == op2.ts) (except for the power
727 Operators need no special handling for scalarized expressions as long as
728 they call gfc_conv_siple_val to get their operands.
729 Character strings get special handling. */
732 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
744 switch (expr->operator)
746 case INTRINSIC_UPLUS:
747 gfc_conv_expr (se, expr->op1);
750 case INTRINSIC_UMINUS:
751 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
755 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
762 case INTRINSIC_MINUS:
766 case INTRINSIC_TIMES:
770 case INTRINSIC_DIVIDE:
771 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
772 an integer, we must round towards zero, so we use a
774 if (expr->ts.type == BT_INTEGER)
775 code = TRUNC_DIV_EXPR;
780 case INTRINSIC_POWER:
781 gfc_conv_power_op (se, expr);
784 case INTRINSIC_CONCAT:
785 gfc_conv_concat_op (se, expr);
789 code = TRUTH_ANDIF_EXPR;
794 code = TRUTH_ORIF_EXPR;
798 /* EQV and NEQV only work on logicals, but since we represent them
799 as integers, we can use EQ_EXPR and NE_EXPR for them in SIMPLE. */
839 case INTRINSIC_ASSIGN:
840 /* These should be converted into function calls by the frontend. */
845 fatal_error ("Unknown intrinsic op");
849 /* The only exception to this is **, which is handled seperately anyway. */
850 assert (expr->op1->ts.type == expr->op2->ts.type);
852 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
856 gfc_init_se (&lse, se);
857 gfc_conv_expr (&lse, expr->op1);
858 gfc_add_block_to_block (&se->pre, &lse.pre);
861 gfc_init_se (&rse, se);
862 gfc_conv_expr (&rse, expr->op2);
863 gfc_add_block_to_block (&se->pre, &rse.pre);
865 /* For string comparisons we generate a library call, and compare the return
869 gfc_conv_string_parameter (&lse);
870 gfc_conv_string_parameter (&rse);
872 tmp = gfc_chainon_list (tmp, lse.string_length);
873 tmp = gfc_chainon_list (tmp, lse.expr);
874 tmp = gfc_chainon_list (tmp, rse.string_length);
875 tmp = gfc_chainon_list (tmp, rse.expr);
877 /* Build a call for the comparison. */
878 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
879 gfc_add_block_to_block (&lse.post, &rse.post);
881 rse.expr = integer_zero_node;
884 type = gfc_typenode_for_spec (&expr->ts);
888 /* The result of logical ops is always boolean_type_node. */
889 tmp = fold (build (code, type, lse.expr, rse.expr));
890 se->expr = convert (type, tmp);
893 se->expr = fold (build (code, type, lse.expr, rse.expr));
896 /* Add the post blocks. */
897 gfc_add_block_to_block (&se->post, &rse.post);
898 gfc_add_block_to_block (&se->post, &lse.post);
902 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
908 tmp = gfc_get_symbol_decl (sym);
909 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
910 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
916 if (!sym->backend_decl)
917 sym->backend_decl = gfc_get_extern_function_decl (sym);
919 tmp = sym->backend_decl;
920 assert (TREE_CODE (tmp) == FUNCTION_DECL);
921 se->expr = gfc_build_addr_expr (NULL, tmp);
926 /* Generate code for a procedure call. Note can return se->post != NULL.
927 If se->direct_byref is set then se->expr contains the return parameter. */
930 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
931 gfc_actual_arglist * arg)
944 gfc_formal_arglist *formal;
947 stringargs = NULL_TREE;
953 if (!sym->attr.elemental)
955 assert (se->ss->type == GFC_SS_FUNCTION);
956 if (se->ss->useflags)
958 assert (gfc_return_by_reference (sym)
959 && sym->result->attr.dimension);
960 assert (se->loop != NULL);
962 /* Access the previously obtained result. */
963 gfc_conv_tmp_array_ref (se);
964 gfc_advance_se_ss_chain (se);
968 info = &se->ss->data.info;
973 byref = gfc_return_by_reference (sym);
976 if (se->direct_byref)
977 arglist = gfc_chainon_list (arglist, se->expr);
978 else if (sym->result->attr.dimension)
980 assert (se->loop && se->ss);
981 /* Set the type of the array. */
982 tmp = gfc_typenode_for_spec (&sym->ts);
983 info->dimen = se->loop->dimen;
984 /* Allocate a temporary to store the result. */
985 gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
987 /* Zero the first stride to indicate a temporary. */
989 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
990 gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
991 /* Pass the temporary as the first argument. */
992 tmp = info->descriptor;
993 tmp = gfc_build_addr_expr (NULL, tmp);
994 arglist = gfc_chainon_list (arglist, tmp);
996 else if (sym->ts.type == BT_CHARACTER)
998 assert (sym->ts.cl && sym->ts.cl->length
999 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1000 len = gfc_conv_mpz_to_tree
1001 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1002 sym->ts.cl->backend_decl = len;
1003 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1004 type = build_pointer_type (type);
1006 var = gfc_conv_string_tmp (se, type, len);
1007 arglist = gfc_chainon_list (arglist, var);
1008 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1011 else /* TODO: derived type function return values. */
1015 formal = sym->formal;
1016 /* Evaluate the arguments. */
1017 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1019 if (arg->expr == NULL)
1022 if (se->ignore_optional)
1024 /* Some intrinsics have already been resolved to the correct
1028 else if (arg->label)
1030 has_alternate_specifier = 1;
1035 /* Pass a NULL pointer for an absent arg. */
1036 gfc_init_se (&parmse, NULL);
1037 parmse.expr = null_pointer_node;
1038 if (formal && formal->sym->ts.type == BT_CHARACTER)
1040 stringargs = gfc_chainon_list (stringargs,
1041 convert (gfc_strlen_type_node, integer_zero_node));
1045 else if (se->ss && se->ss->useflags)
1047 /* An elemental function inside a scalarized loop. */
1048 gfc_init_se (&parmse, se);
1049 gfc_conv_expr_reference (&parmse, arg->expr);
1053 /* A scalar or transformational function. */
1054 gfc_init_se (&parmse, NULL);
1055 argss = gfc_walk_expr (arg->expr);
1057 if (argss == gfc_ss_terminator)
1059 gfc_conv_expr_reference (&parmse, arg->expr);
1060 if (formal && formal->sym->attr.pointer)
1062 /* Scalar pointer dummy args require an extra level of
1064 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1069 /* If the procedure requires explicit interface, actual argument
1070 is passed according to corresponing formal argument. We
1071 do not use g77 method and the address of array descriptor
1072 is passed if corresponing formal is pointer or
1073 assumed-shape, Otherwise use g77 method. */
1075 f = (formal != NULL)
1076 && !formal->sym->attr.pointer
1077 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1078 f = f || !sym->attr.always_explicit;
1079 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1083 gfc_add_block_to_block (&se->pre, &parmse.pre);
1084 gfc_add_block_to_block (&se->post, &parmse.post);
1086 /* Character strings are passed as two paramarers, a length and a
1088 if (parmse.string_length != NULL_TREE)
1089 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1091 arglist = gfc_chainon_list (arglist, parmse.expr);
1094 /* Add the hidden string length parameters to the arguments. */
1095 arglist = chainon (arglist, stringargs);
1097 /* Generate the actual call. */
1098 gfc_conv_function_val (se, sym);
1099 /* If there are alternate return labels, function type should be
1101 if (has_alternate_specifier)
1102 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1104 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1105 se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1106 arglist, NULL_TREE);
1108 /* A pure function may still have side-effects - it may modify its
1110 TREE_SIDE_EFFECTS (se->expr) = 1;
1112 if (!sym->attr.pure)
1113 TREE_SIDE_EFFECTS (se->expr) = 1;
1116 if (byref && !se->direct_byref)
1118 gfc_add_expr_to_block (&se->pre, se->expr);
1120 if (sym->result->attr.dimension)
1122 if (flag_bounds_check)
1124 /* Check the data pointer hasn't been modified. This would happen
1125 in a function returning a pointer. */
1126 tmp = gfc_conv_descriptor_data (info->descriptor);
1127 tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
1128 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1130 se->expr = info->descriptor;
1132 else if (sym->ts.type == BT_CHARACTER)
1135 se->string_length = len;
1143 /* Translate a statement function.
1144 The value of a statement function reference is obtained by evaluating the
1145 expression using the values of the actual arguments for the values of the
1146 corresponding dummy arguments. */
1149 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1153 gfc_formal_arglist *fargs;
1154 gfc_actual_arglist *args;
1158 sym = expr->symtree->n.sym;
1159 args = expr->value.function.actual;
1160 gfc_init_se (&lse, NULL);
1161 gfc_init_se (&rse, NULL);
1163 for (fargs = sym->formal; fargs; fargs = fargs->next)
1165 /* Each dummy shall be specified, explicitly or implicitly, to be
1167 assert (fargs->sym->attr.dimension == 0);
1169 assert (fsym->backend_decl);
1171 /* Convert non-pointer string dummy. */
1172 if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer)
1181 assert (fsym->ts.cl && fsym->ts.cl->length
1182 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1184 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl);
1185 len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1186 var = gfc_build_addr_expr (build_pointer_type (type),
1187 fsym->backend_decl);
1189 gfc_conv_expr (&rse, args->expr);
1190 gfc_conv_string_parameter (&rse);
1191 len2 = rse.string_length;
1192 gfc_add_block_to_block (&se->pre, &lse.pre);
1193 gfc_add_block_to_block (&se->pre, &rse.pre);
1196 arg = gfc_chainon_list (arg, len1);
1197 arg = gfc_chainon_list (arg, var);
1198 arg = gfc_chainon_list (arg, len2);
1199 arg = gfc_chainon_list (arg, rse.expr);
1200 tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg);
1201 gfc_add_expr_to_block (&se->pre, tmp);
1202 gfc_add_block_to_block (&se->pre, &lse.post);
1203 gfc_add_block_to_block (&se->pre, &rse.post);
1207 /* For everything else, just evaluate the expression. */
1208 if (fsym->attr.pointer == 1)
1209 lse.want_pointer = 1;
1211 gfc_conv_expr (&lse, args->expr);
1213 gfc_add_block_to_block (&se->pre, &lse.pre);
1214 gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr);
1215 gfc_add_block_to_block (&se->pre, &lse.post);
1219 gfc_conv_expr (se, sym->value);
1223 /* Translate a function expression. */
1226 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1230 if (expr->value.function.isym)
1232 gfc_conv_intrinsic_function (se, expr);
1236 /* We distinguish the statement function from general function to improve
1237 runtime performance. */
1238 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1240 gfc_conv_statement_function (se, expr);
1244 /* expr.value.function.esym is the resolved (specific) function symbol for
1245 most functions. However this isn't set for dummy procedures. */
1246 sym = expr->value.function.esym;
1248 sym = expr->symtree->n.sym;
1249 gfc_conv_function_call (se, sym, expr->value.function.actual);
1253 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1255 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1256 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1258 gfc_conv_tmp_array_ref (se);
1259 gfc_advance_se_ss_chain (se);
1264 /* Build an expression for a constructor. If init is nonzero then
1265 this is part of a static variable initializer. */
1268 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1279 assert (expr->expr_type == EXPR_STRUCTURE);
1280 type = gfc_typenode_for_spec (&expr->ts);
1281 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1284 cm = expr->ts.derived->components;
1285 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1287 /* Skip absent members in default initializers. */
1291 gfc_init_se (&cse, se);
1292 /* Evaluate the expression for this component. */
1295 switch (c->expr->expr_type)
1298 arraytype = TREE_TYPE (cm->backend_decl);
1299 cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
1302 case EXPR_STRUCTURE:
1303 gfc_conv_structure (&cse, c->expr, 1);
1307 gfc_conv_expr (&cse, c->expr);
1312 gfc_conv_expr (&cse, c->expr);
1313 gfc_add_block_to_block (&se->pre, &cse.pre);
1314 gfc_add_block_to_block (&se->post, &cse.post);
1317 /* Build a TREE_CHAIN to hold it. */
1318 val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
1320 /* Add it to the list. */
1321 if (tail == NULL_TREE)
1322 TREE_OPERAND(head, 0) = tail = val;
1325 TREE_CHAIN (tail) = val;
1333 /*translate a substring expression */
1336 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1342 assert(ref->type == REF_SUBSTRING);
1344 se->expr = gfc_build_string_const(expr->value.character.length,
1345 expr->value.character.string);
1346 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1347 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1349 gfc_conv_substring(se,ref,expr->ts.kind);
1353 /* Entry point for expression translation. */
1356 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1358 if (se->ss && se->ss->expr == expr
1359 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1361 /* Substiture a scalar expression evaluated outside the scalarization
1363 se->expr = se->ss->data.scalar.expr;
1364 se->string_length = se->ss->data.scalar.string_length;
1365 gfc_advance_se_ss_chain (se);
1369 switch (expr->expr_type)
1372 gfc_conv_expr_op (se, expr);
1376 gfc_conv_function_expr (se, expr);
1380 gfc_conv_constant (se, expr);
1384 gfc_conv_variable (se, expr);
1388 se->expr = null_pointer_node;
1391 case EXPR_SUBSTRING:
1392 gfc_conv_substring_expr (se, expr);
1395 case EXPR_STRUCTURE:
1396 gfc_conv_structure (se, expr, 0);
1400 gfc_conv_array_constructor_expr (se, expr);
1410 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1412 gfc_conv_expr (se, expr);
1413 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1414 figure out a way of rewriting an lvalue so that it has no post chain. */
1415 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1419 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1423 assert (expr->ts.type != BT_CHARACTER);
1424 gfc_conv_expr (se, expr);
1427 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1428 gfc_add_modify_expr (&se->pre, val, se->expr);
1433 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1435 gfc_conv_expr_val (se, expr);
1436 se->expr = convert (type, se->expr);
1440 /* Converts an expression so that it can be passed by refernece. Scalar
1444 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1448 if (se->ss && se->ss->expr == expr
1449 && se->ss->type == GFC_SS_REFERENCE)
1451 se->expr = se->ss->data.scalar.expr;
1452 se->string_length = se->ss->data.scalar.string_length;
1453 gfc_advance_se_ss_chain (se);
1457 if (expr->ts.type == BT_CHARACTER)
1459 gfc_conv_expr (se, expr);
1460 gfc_conv_string_parameter (se);
1464 if (expr->expr_type == EXPR_VARIABLE)
1466 se->want_pointer = 1;
1467 gfc_conv_expr (se, expr);
1470 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1471 gfc_add_modify_expr (&se->pre, var, se->expr);
1472 gfc_add_block_to_block (&se->pre, &se->post);
1478 gfc_conv_expr (se, expr);
1480 /* Create a temporary var to hold the value. */
1481 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1482 gfc_add_modify_expr (&se->pre, var, se->expr);
1483 gfc_add_block_to_block (&se->pre, &se->post);
1485 /* Take the address of that value. */
1486 se->expr = gfc_build_addr_expr (NULL, var);
1491 gfc_trans_pointer_assign (gfc_code * code)
1493 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1498 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1507 gfc_start_block (&block);
1509 gfc_init_se (&lse, NULL);
1511 lss = gfc_walk_expr (expr1);
1512 rss = gfc_walk_expr (expr2);
1513 if (lss == gfc_ss_terminator)
1515 lse.want_pointer = 1;
1516 gfc_conv_expr (&lse, expr1);
1517 assert (rss == gfc_ss_terminator);
1518 gfc_init_se (&rse, NULL);
1519 rse.want_pointer = 1;
1520 gfc_conv_expr (&rse, expr2);
1521 gfc_add_block_to_block (&block, &lse.pre);
1522 gfc_add_block_to_block (&block, &rse.pre);
1523 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1524 gfc_add_block_to_block (&block, &rse.post);
1525 gfc_add_block_to_block (&block, &lse.post);
1529 gfc_conv_expr_descriptor (&lse, expr1, lss);
1530 /* Implement Nullify. */
1531 if (expr2->expr_type == EXPR_NULL)
1533 lse.expr = gfc_conv_descriptor_data (lse.expr);
1534 rse.expr = null_pointer_node;
1535 tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
1536 gfc_add_expr_to_block (&block, tmp);
1540 lse.direct_byref = 1;
1541 gfc_conv_expr_descriptor (&lse, expr2, rss);
1543 gfc_add_block_to_block (&block, &lse.pre);
1544 gfc_add_block_to_block (&block, &lse.post);
1546 return gfc_finish_block (&block);
1550 /* Makes sure se is suitable for passing as a function string parameter. */
1551 /* TODO: Need to check all callers fo this function. It may be abused. */
1554 gfc_conv_string_parameter (gfc_se * se)
1558 if (TREE_CODE (se->expr) == STRING_CST)
1560 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1564 type = TREE_TYPE (se->expr);
1565 if (TYPE_STRING_FLAG (type))
1567 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1568 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1571 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1572 assert (se->string_length
1573 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1577 /* Generate code for assignment of scalar variables. Includes character
1581 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1587 gfc_init_block (&block);
1590 if (type == BT_CHARACTER)
1594 assert (lse->string_length != NULL_TREE
1595 && rse->string_length != NULL_TREE);
1597 gfc_conv_string_parameter (lse);
1598 gfc_conv_string_parameter (rse);
1600 gfc_add_block_to_block (&block, &lse->pre);
1601 gfc_add_block_to_block (&block, &rse->pre);
1603 args = gfc_chainon_list (args, lse->string_length);
1604 args = gfc_chainon_list (args, lse->expr);
1605 args = gfc_chainon_list (args, rse->string_length);
1606 args = gfc_chainon_list (args, rse->expr);
1608 tmp = gfc_build_function_call (gfor_fndecl_copy_string, args);
1609 gfc_add_expr_to_block (&block, tmp);
1613 gfc_add_block_to_block (&block, &lse->pre);
1614 gfc_add_block_to_block (&block, &rse->pre);
1616 gfc_add_modify_expr (&block, lse->expr, rse->expr);
1619 gfc_add_block_to_block (&block, &lse->post);
1620 gfc_add_block_to_block (&block, &rse->post);
1622 return gfc_finish_block (&block);
1626 /* Try to translate array(:) = func (...), where func is a transformational
1627 array function, without using a temporary. Returns NULL is this isn't the
1631 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1636 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1637 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1640 /* Elemental functions don't need a temporary anyway. */
1641 if (expr2->symtree->n.sym->attr.elemental)
1644 /* Check for a dependency. */
1645 if (gfc_check_fncall_dependency (expr1, expr2))
1648 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1650 assert (expr2->value.function.isym
1651 || (gfc_return_by_reference (expr2->symtree->n.sym)
1652 && expr2->symtree->n.sym->result->attr.dimension));
1654 ss = gfc_walk_expr (expr1);
1655 assert (ss != gfc_ss_terminator);
1656 gfc_init_se (&se, NULL);
1657 gfc_start_block (&se.pre);
1658 se.want_pointer = 1;
1660 gfc_conv_array_parameter (&se, expr1, ss, 0);
1662 se.direct_byref = 1;
1663 se.ss = gfc_walk_expr (expr2);
1664 assert (se.ss != gfc_ss_terminator);
1665 gfc_conv_function_expr (&se, expr2);
1666 gfc_add_expr_to_block (&se.pre, se.expr);
1667 gfc_add_block_to_block (&se.pre, &se.post);
1669 return gfc_finish_block (&se.pre);
1673 /* Translate an assignment. Most of the code is concerned with
1674 setting up the scalarizer. */
1677 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
1682 gfc_ss *lss_section;
1689 /* Special case a single function returning an array. */
1690 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
1692 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
1697 /* Assignment of the form lhs = rhs. */
1698 gfc_start_block (&block);
1700 gfc_init_se (&lse, NULL);
1701 gfc_init_se (&rse, NULL);
1704 lss = gfc_walk_expr (expr1);
1706 if (lss != gfc_ss_terminator)
1708 /* The assignment needs scalarization. */
1711 /* Find a non-scalar SS from the lhs. */
1712 while (lss_section != gfc_ss_terminator
1713 && lss_section->type != GFC_SS_SECTION)
1714 lss_section = lss_section->next;
1716 assert (lss_section != gfc_ss_terminator);
1718 /* Initialize the scalarizer. */
1719 gfc_init_loopinfo (&loop);
1722 rss = gfc_walk_expr (expr2);
1723 if (rss == gfc_ss_terminator)
1725 /* The rhs is scalar. Add a ss for the expression. */
1726 rss = gfc_get_ss ();
1727 rss->next = gfc_ss_terminator;
1728 rss->type = GFC_SS_SCALAR;
1731 /* Associate the SS with the loop. */
1732 gfc_add_ss_to_loop (&loop, lss);
1733 gfc_add_ss_to_loop (&loop, rss);
1735 /* Calculate the bounds of the scalarization. */
1736 gfc_conv_ss_startstride (&loop);
1737 /* Resolve any data dependencies in the statement. */
1738 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
1739 /* Setup the scalarizing loops. */
1740 gfc_conv_loop_setup (&loop);
1742 /* Setup the gfc_se structures. */
1743 gfc_copy_loopinfo_to_se (&lse, &loop);
1744 gfc_copy_loopinfo_to_se (&rse, &loop);
1747 gfc_mark_ss_chain_used (rss, 1);
1748 if (loop.temp_ss == NULL)
1751 gfc_mark_ss_chain_used (lss, 1);
1755 lse.ss = loop.temp_ss;
1756 gfc_mark_ss_chain_used (lss, 3);
1757 gfc_mark_ss_chain_used (loop.temp_ss, 3);
1760 /* Start the scalarized loop body. */
1761 gfc_start_scalarized_body (&loop, &body);
1764 gfc_init_block (&body);
1766 /* Translate the expression. */
1767 gfc_conv_expr (&rse, expr2);
1769 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
1771 gfc_conv_tmp_array_ref (&lse);
1772 gfc_advance_se_ss_chain (&lse);
1775 gfc_conv_expr (&lse, expr1);
1777 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1778 gfc_add_expr_to_block (&body, tmp);
1780 if (lss == gfc_ss_terminator)
1782 /* Use the scalar assignment as is. */
1783 gfc_add_block_to_block (&block, &body);
1787 if (lse.ss != gfc_ss_terminator)
1789 if (rse.ss != gfc_ss_terminator)
1792 if (loop.temp_ss != NULL)
1794 gfc_trans_scalarized_loop_boundary (&loop, &body);
1796 /* We need to copy the temporary to the actual lhs. */
1797 gfc_init_se (&lse, NULL);
1798 gfc_init_se (&rse, NULL);
1799 gfc_copy_loopinfo_to_se (&lse, &loop);
1800 gfc_copy_loopinfo_to_se (&rse, &loop);
1802 rse.ss = loop.temp_ss;
1805 gfc_conv_tmp_array_ref (&rse);
1806 gfc_advance_se_ss_chain (&rse);
1807 gfc_conv_expr (&lse, expr1);
1809 if (lse.ss != gfc_ss_terminator)
1812 if (rse.ss != gfc_ss_terminator)
1815 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1816 gfc_add_expr_to_block (&body, tmp);
1818 /* Generate the copying loops. */
1819 gfc_trans_scalarizing_loops (&loop, &body);
1821 /* Wrap the whole thing up. */
1822 gfc_add_block_to_block (&block, &loop.pre);
1823 gfc_add_block_to_block (&block, &loop.post);
1825 gfc_cleanup_loop (&loop);
1828 return gfc_finish_block (&block);
1832 gfc_trans_assign (gfc_code * code)
1834 return gfc_trans_assignment (code->expr, code->expr2);