1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
163 /* Test for a NULL value. */
164 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
165 fold_convert (TREE_TYPE (tmp), integer_one_node));
166 tmp = gfc_evaluate_now (tmp, &se->pre);
167 se->expr = build_fold_addr_expr (tmp);
171 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
172 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
173 tmp = gfc_evaluate_now (tmp, &se->pre);
177 if (ts.type == BT_CHARACTER)
179 tmp = build_int_cst (gfc_charlen_type_node, 0);
180 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
181 present, se->string_length, tmp);
182 tmp = gfc_evaluate_now (tmp, &se->pre);
183 se->string_length = tmp;
189 /* Get the character length of an expression, looking through gfc_refs
193 gfc_get_expr_charlen (gfc_expr *e)
198 gcc_assert (e->expr_type == EXPR_VARIABLE
199 && e->ts.type == BT_CHARACTER);
201 length = NULL; /* To silence compiler warning. */
203 if (is_subref_array (e) && e->ts.cl->length)
206 gfc_init_se (&tmpse, NULL);
207 gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
208 e->ts.cl->backend_decl = tmpse.expr;
212 /* First candidate: if the variable is of type CHARACTER, the
213 expression's length could be the length of the character
215 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
216 length = e->symtree->n.sym->ts.cl->backend_decl;
218 /* Look through the reference chain for component references. */
219 for (r = e->ref; r; r = r->next)
224 if (r->u.c.component->ts.type == BT_CHARACTER)
225 length = r->u.c.component->ts.cl->backend_decl;
233 /* We should never got substring references here. These will be
234 broken down by the scalarizer. */
240 gcc_assert (length != NULL);
245 /* For each character array constructor subexpression without a ts.cl->length,
246 replace it by its first element (if there aren't any elements, the length
247 should already be set to zero). */
250 flatten_array_ctors_without_strlen (gfc_expr* e)
252 gfc_actual_arglist* arg;
258 switch (e->expr_type)
262 flatten_array_ctors_without_strlen (e->value.op.op1);
263 flatten_array_ctors_without_strlen (e->value.op.op2);
267 /* TODO: Implement as with EXPR_FUNCTION when needed. */
271 for (arg = e->value.function.actual; arg; arg = arg->next)
272 flatten_array_ctors_without_strlen (arg->expr);
277 /* We've found what we're looking for. */
278 if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
281 gcc_assert (e->value.constructor);
283 new_expr = e->value.constructor->expr;
284 e->value.constructor->expr = NULL;
286 flatten_array_ctors_without_strlen (new_expr);
287 gfc_replace_expr (e, new_expr);
291 /* Otherwise, fall through to handle constructor elements. */
293 for (c = e->value.constructor; c; c = c->next)
294 flatten_array_ctors_without_strlen (c->expr);
304 /* Generate code to initialize a string length variable. Returns the
305 value. For array constructors, cl->length might be NULL and in this case,
306 the first element of the constructor is needed. expr is the original
307 expression so we can access it but can be NULL if this is not needed. */
310 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
314 gfc_init_se (&se, NULL);
316 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
317 "flatten" array constructors by taking their first element; all elements
318 should be the same length or a cl->length should be present. */
324 expr_flat = gfc_copy_expr (expr);
325 flatten_array_ctors_without_strlen (expr_flat);
326 gfc_resolve_expr (expr_flat);
328 gfc_conv_expr (&se, expr_flat);
329 gfc_add_block_to_block (pblock, &se.pre);
330 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
332 gfc_free_expr (expr_flat);
336 /* Convert cl->length. */
338 gcc_assert (cl->length);
340 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
341 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
342 build_int_cst (gfc_charlen_type_node, 0));
343 gfc_add_block_to_block (pblock, &se.pre);
345 if (cl->backend_decl)
346 gfc_add_modify (pblock, cl->backend_decl, se.expr);
348 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
353 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
354 const char *name, locus *where)
364 type = gfc_get_character_type (kind, ref->u.ss.length);
365 type = build_pointer_type (type);
368 gfc_init_se (&start, se);
369 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
370 gfc_add_block_to_block (&se->pre, &start.pre);
372 if (integer_onep (start.expr))
373 gfc_conv_string_parameter (se);
376 /* Avoid multiple evaluation of substring start. */
377 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
378 start.expr = gfc_evaluate_now (start.expr, &se->pre);
380 /* Change the start of the string. */
381 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
384 tmp = build_fold_indirect_ref (se->expr);
385 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
386 se->expr = gfc_build_addr_expr (type, tmp);
389 /* Length = end + 1 - start. */
390 gfc_init_se (&end, se);
391 if (ref->u.ss.end == NULL)
392 end.expr = se->string_length;
395 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
396 gfc_add_block_to_block (&se->pre, &end.pre);
398 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
399 end.expr = gfc_evaluate_now (end.expr, &se->pre);
401 if (flag_bounds_check)
403 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
404 start.expr, end.expr);
406 /* Check lower bound. */
407 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
408 build_int_cst (gfc_charlen_type_node, 1));
409 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
412 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
413 "is less than one", name);
415 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
417 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
418 fold_convert (long_integer_type_node,
422 /* Check upper bound. */
423 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
425 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
428 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
429 "exceeds string length (%%ld)", name);
431 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
432 "exceeds string length (%%ld)");
433 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
434 fold_convert (long_integer_type_node, end.expr),
435 fold_convert (long_integer_type_node,
440 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
441 build_int_cst (gfc_charlen_type_node, 1),
443 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
444 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
445 build_int_cst (gfc_charlen_type_node, 0));
446 se->string_length = tmp;
450 /* Convert a derived type component reference. */
453 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
460 c = ref->u.c.component;
462 gcc_assert (c->backend_decl);
464 field = c->backend_decl;
465 gcc_assert (TREE_CODE (field) == FIELD_DECL);
467 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
471 if (c->ts.type == BT_CHARACTER)
473 tmp = c->ts.cl->backend_decl;
474 /* Components must always be constant length. */
475 gcc_assert (tmp && INTEGER_CST_P (tmp));
476 se->string_length = tmp;
479 if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
480 se->expr = build_fold_indirect_ref (se->expr);
484 /* This function deals with component references to components of the
485 parent type for derived type extensons. */
487 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
495 c = ref->u.c.component;
497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
498 parent.type = REF_COMPONENT;
501 parent.u.c.component = dt->components;
503 if (dt->attr.extension && dt->components)
505 /* Return if the component is not in the parent type. */
506 for (cmp = dt->components->next; cmp; cmp = cmp->next)
507 if (strcmp (c->name, cmp->name) == 0)
510 /* Otherwise build the reference and call self. */
511 gfc_conv_component_ref (se, &parent);
512 parent.u.c.sym = dt->components->ts.derived;
513 parent.u.c.component = c;
514 conv_parent_component_references (se, &parent);
518 /* Return the contents of a variable. Also handles reference/pointer
519 variables (all Fortran pointer references are implicit). */
522 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
529 bool alternate_entry;
532 sym = expr->symtree->n.sym;
535 /* Check that something hasn't gone horribly wrong. */
536 gcc_assert (se->ss != gfc_ss_terminator);
537 gcc_assert (se->ss->expr == expr);
539 /* A scalarized term. We already know the descriptor. */
540 se->expr = se->ss->data.info.descriptor;
541 se->string_length = se->ss->string_length;
542 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
543 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
548 tree se_expr = NULL_TREE;
550 se->expr = gfc_get_symbol_decl (sym);
552 /* Deal with references to a parent results or entries by storing
553 the current_function_decl and moving to the parent_decl. */
554 return_value = sym->attr.function && sym->result == sym;
555 alternate_entry = sym->attr.function && sym->attr.entry
556 && sym->result == sym;
557 entry_master = sym->attr.result
558 && sym->ns->proc_name->attr.entry_master
559 && !gfc_return_by_reference (sym->ns->proc_name);
560 parent_decl = DECL_CONTEXT (current_function_decl);
562 if ((se->expr == parent_decl && return_value)
563 || (sym->ns && sym->ns->proc_name
565 && sym->ns->proc_name->backend_decl == parent_decl
566 && (alternate_entry || entry_master)))
571 /* Special case for assigning the return value of a function.
572 Self recursive functions must have an explicit return value. */
573 if (return_value && (se->expr == current_function_decl || parent_flag))
574 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
576 /* Similarly for alternate entry points. */
577 else if (alternate_entry
578 && (sym->ns->proc_name->backend_decl == current_function_decl
581 gfc_entry_list *el = NULL;
583 for (el = sym->ns->entries; el; el = el->next)
586 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
591 else if (entry_master
592 && (sym->ns->proc_name->backend_decl == current_function_decl
594 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
599 /* Procedure actual arguments. */
600 else if (sym->attr.flavor == FL_PROCEDURE
601 && se->expr != current_function_decl)
603 if (!sym->attr.dummy && !sym->attr.proc_pointer)
605 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
606 se->expr = build_fold_addr_expr (se->expr);
612 /* Dereference the expression, where needed. Since characters
613 are entirely different from other types, they are treated
615 if (sym->ts.type == BT_CHARACTER)
617 /* Dereference character pointer dummy arguments
619 if ((sym->attr.pointer || sym->attr.allocatable)
621 || sym->attr.function
622 || sym->attr.result))
623 se->expr = build_fold_indirect_ref (se->expr);
626 else if (!sym->attr.value)
628 /* Dereference non-character scalar dummy arguments. */
629 if (sym->attr.dummy && !sym->attr.dimension)
630 se->expr = build_fold_indirect_ref (se->expr);
632 /* Dereference scalar hidden result. */
633 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
634 && (sym->attr.function || sym->attr.result)
635 && !sym->attr.dimension && !sym->attr.pointer
636 && !sym->attr.always_explicit)
637 se->expr = build_fold_indirect_ref (se->expr);
639 /* Dereference non-character pointer variables.
640 These must be dummies, results, or scalars. */
641 if ((sym->attr.pointer || sym->attr.allocatable)
643 || sym->attr.function
645 || !sym->attr.dimension))
646 se->expr = build_fold_indirect_ref (se->expr);
652 /* For character variables, also get the length. */
653 if (sym->ts.type == BT_CHARACTER)
655 /* If the character length of an entry isn't set, get the length from
656 the master function instead. */
657 if (sym->attr.entry && !sym->ts.cl->backend_decl)
658 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
660 se->string_length = sym->ts.cl->backend_decl;
661 gcc_assert (se->string_length);
669 /* Return the descriptor if that's what we want and this is an array
670 section reference. */
671 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
673 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
674 /* Return the descriptor for array pointers and allocations. */
676 && ref->next == NULL && (se->descriptor_only))
679 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
680 /* Return a pointer to an element. */
684 if (ref->u.c.sym->attr.extension)
685 conv_parent_component_references (se, ref);
687 gfc_conv_component_ref (se, ref);
691 gfc_conv_substring (se, ref, expr->ts.kind,
692 expr->symtree->name, &expr->where);
701 /* Pointer assignment, allocation or pass by reference. Arrays are handled
703 if (se->want_pointer)
705 if (expr->ts.type == BT_CHARACTER)
706 gfc_conv_string_parameter (se);
708 se->expr = build_fold_addr_expr (se->expr);
713 /* Unary ops are easy... Or they would be if ! was a valid op. */
716 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
721 gcc_assert (expr->ts.type != BT_CHARACTER);
722 /* Initialize the operand. */
723 gfc_init_se (&operand, se);
724 gfc_conv_expr_val (&operand, expr->value.op.op1);
725 gfc_add_block_to_block (&se->pre, &operand.pre);
727 type = gfc_typenode_for_spec (&expr->ts);
729 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
730 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
731 All other unary operators have an equivalent GIMPLE unary operator. */
732 if (code == TRUTH_NOT_EXPR)
733 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
734 build_int_cst (type, 0));
736 se->expr = fold_build1 (code, type, operand.expr);
740 /* Expand power operator to optimal multiplications when a value is raised
741 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
742 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
743 Programming", 3rd Edition, 1998. */
745 /* This code is mostly duplicated from expand_powi in the backend.
746 We establish the "optimal power tree" lookup table with the defined size.
747 The items in the table are the exponents used to calculate the index
748 exponents. Any integer n less than the value can get an "addition chain",
749 with the first node being one. */
750 #define POWI_TABLE_SIZE 256
752 /* The table is from builtins.c. */
753 static const unsigned char powi_table[POWI_TABLE_SIZE] =
755 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
756 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
757 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
758 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
759 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
760 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
761 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
762 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
763 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
764 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
765 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
766 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
767 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
768 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
769 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
770 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
771 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
772 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
773 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
774 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
775 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
776 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
777 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
778 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
779 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
780 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
781 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
782 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
783 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
784 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
785 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
786 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
789 /* If n is larger than lookup table's max index, we use the "window
791 #define POWI_WINDOW_SIZE 3
793 /* Recursive function to expand the power operator. The temporary
794 values are put in tmpvar. The function returns tmpvar[1] ** n. */
796 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
803 if (n < POWI_TABLE_SIZE)
808 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
809 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
813 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
814 op0 = gfc_conv_powi (se, n - digit, tmpvar);
815 op1 = gfc_conv_powi (se, digit, tmpvar);
819 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
823 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
824 tmp = gfc_evaluate_now (tmp, &se->pre);
826 if (n < POWI_TABLE_SIZE)
833 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
834 return 1. Else return 0 and a call to runtime library functions
835 will have to be built. */
837 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
842 tree vartmp[POWI_TABLE_SIZE];
844 unsigned HOST_WIDE_INT n;
847 /* If exponent is too large, we won't expand it anyway, so don't bother
848 with large integer values. */
849 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
852 m = double_int_to_shwi (TREE_INT_CST (rhs));
853 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
854 of the asymmetric range of the integer type. */
855 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
857 type = TREE_TYPE (lhs);
858 sgn = tree_int_cst_sgn (rhs);
860 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
861 || optimize_size) && (m > 2 || m < -1))
867 se->expr = gfc_build_const (type, integer_one_node);
871 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
872 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
874 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
875 lhs, build_int_cst (TREE_TYPE (lhs), -1));
876 cond = fold_build2 (EQ_EXPR, boolean_type_node,
877 lhs, build_int_cst (TREE_TYPE (lhs), 1));
880 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
883 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
884 se->expr = fold_build3 (COND_EXPR, type,
885 tmp, build_int_cst (type, 1),
886 build_int_cst (type, 0));
890 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
891 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
892 build_int_cst (type, 0));
893 se->expr = fold_build3 (COND_EXPR, type,
894 cond, build_int_cst (type, 1), tmp);
898 memset (vartmp, 0, sizeof (vartmp));
902 tmp = gfc_build_const (type, integer_one_node);
903 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
906 se->expr = gfc_conv_powi (se, n, vartmp);
912 /* Power op (**). Constant integer exponent has special handling. */
915 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
917 tree gfc_int4_type_node;
924 gfc_init_se (&lse, se);
925 gfc_conv_expr_val (&lse, expr->value.op.op1);
926 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
927 gfc_add_block_to_block (&se->pre, &lse.pre);
929 gfc_init_se (&rse, se);
930 gfc_conv_expr_val (&rse, expr->value.op.op2);
931 gfc_add_block_to_block (&se->pre, &rse.pre);
933 if (expr->value.op.op2->ts.type == BT_INTEGER
934 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
935 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
938 gfc_int4_type_node = gfc_get_int_type (4);
940 kind = expr->value.op.op1->ts.kind;
941 switch (expr->value.op.op2->ts.type)
944 ikind = expr->value.op.op2->ts.kind;
949 rse.expr = convert (gfc_int4_type_node, rse.expr);
971 if (expr->value.op.op1->ts.type == BT_INTEGER)
972 lse.expr = convert (gfc_int4_type_node, lse.expr);
997 switch (expr->value.op.op1->ts.type)
1000 if (kind == 3) /* Case 16 was not handled properly above. */
1002 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1006 /* Use builtins for real ** int4. */
1012 fndecl = built_in_decls[BUILT_IN_POWIF];
1016 fndecl = built_in_decls[BUILT_IN_POWI];
1021 fndecl = built_in_decls[BUILT_IN_POWIL];
1029 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1033 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1045 fndecl = built_in_decls[BUILT_IN_POWF];
1048 fndecl = built_in_decls[BUILT_IN_POW];
1052 fndecl = built_in_decls[BUILT_IN_POWL];
1063 fndecl = built_in_decls[BUILT_IN_CPOWF];
1066 fndecl = built_in_decls[BUILT_IN_CPOW];
1070 fndecl = built_in_decls[BUILT_IN_CPOWL];
1082 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
1086 /* Generate code to allocate a string temporary. */
1089 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1094 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
1096 if (gfc_can_put_var_on_stack (len))
1098 /* Create a temporary variable to hold the result. */
1099 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1100 build_int_cst (gfc_charlen_type_node, 1));
1101 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1103 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1104 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1106 tmp = build_array_type (TREE_TYPE (type), tmp);
1108 var = gfc_create_var (tmp, "str");
1109 var = gfc_build_addr_expr (type, var);
1113 /* Allocate a temporary to hold the result. */
1114 var = gfc_create_var (type, "pstr");
1115 tmp = gfc_call_malloc (&se->pre, type,
1116 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1117 fold_convert (TREE_TYPE (len),
1118 TYPE_SIZE (type))));
1119 gfc_add_modify (&se->pre, var, tmp);
1121 /* Free the temporary afterwards. */
1122 tmp = gfc_call_free (convert (pvoid_type_node, var));
1123 gfc_add_expr_to_block (&se->post, tmp);
1130 /* Handle a string concatenation operation. A temporary will be allocated to
1134 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1137 tree len, type, var, tmp, fndecl;
1139 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1140 && expr->value.op.op2->ts.type == BT_CHARACTER);
1141 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1143 gfc_init_se (&lse, se);
1144 gfc_conv_expr (&lse, expr->value.op.op1);
1145 gfc_conv_string_parameter (&lse);
1146 gfc_init_se (&rse, se);
1147 gfc_conv_expr (&rse, expr->value.op.op2);
1148 gfc_conv_string_parameter (&rse);
1150 gfc_add_block_to_block (&se->pre, &lse.pre);
1151 gfc_add_block_to_block (&se->pre, &rse.pre);
1153 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1154 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1155 if (len == NULL_TREE)
1157 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1158 lse.string_length, rse.string_length);
1161 type = build_pointer_type (type);
1163 var = gfc_conv_string_tmp (se, type, len);
1165 /* Do the actual concatenation. */
1166 if (expr->ts.kind == 1)
1167 fndecl = gfor_fndecl_concat_string;
1168 else if (expr->ts.kind == 4)
1169 fndecl = gfor_fndecl_concat_string_char4;
1173 tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
1174 rse.string_length, rse.expr);
1175 gfc_add_expr_to_block (&se->pre, tmp);
1177 /* Add the cleanup for the operands. */
1178 gfc_add_block_to_block (&se->pre, &rse.post);
1179 gfc_add_block_to_block (&se->pre, &lse.post);
1182 se->string_length = len;
1185 /* Translates an op expression. Common (binary) cases are handled by this
1186 function, others are passed on. Recursion is used in either case.
1187 We use the fact that (op1.ts == op2.ts) (except for the power
1189 Operators need no special handling for scalarized expressions as long as
1190 they call gfc_conv_simple_val to get their operands.
1191 Character strings get special handling. */
1194 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1196 enum tree_code code;
1205 switch (expr->value.op.op)
1207 case INTRINSIC_PARENTHESES:
1208 if (expr->ts.type == BT_REAL
1209 || expr->ts.type == BT_COMPLEX)
1211 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1212 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1217 case INTRINSIC_UPLUS:
1218 gfc_conv_expr (se, expr->value.op.op1);
1221 case INTRINSIC_UMINUS:
1222 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1226 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1229 case INTRINSIC_PLUS:
1233 case INTRINSIC_MINUS:
1237 case INTRINSIC_TIMES:
1241 case INTRINSIC_DIVIDE:
1242 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1243 an integer, we must round towards zero, so we use a
1245 if (expr->ts.type == BT_INTEGER)
1246 code = TRUNC_DIV_EXPR;
1251 case INTRINSIC_POWER:
1252 gfc_conv_power_op (se, expr);
1255 case INTRINSIC_CONCAT:
1256 gfc_conv_concat_op (se, expr);
1260 code = TRUTH_ANDIF_EXPR;
1265 code = TRUTH_ORIF_EXPR;
1269 /* EQV and NEQV only work on logicals, but since we represent them
1270 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1272 case INTRINSIC_EQ_OS:
1280 case INTRINSIC_NE_OS:
1281 case INTRINSIC_NEQV:
1288 case INTRINSIC_GT_OS:
1295 case INTRINSIC_GE_OS:
1302 case INTRINSIC_LT_OS:
1309 case INTRINSIC_LE_OS:
1315 case INTRINSIC_USER:
1316 case INTRINSIC_ASSIGN:
1317 /* These should be converted into function calls by the frontend. */
1321 fatal_error ("Unknown intrinsic op");
1325 /* The only exception to this is **, which is handled separately anyway. */
1326 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1328 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1332 gfc_init_se (&lse, se);
1333 gfc_conv_expr (&lse, expr->value.op.op1);
1334 gfc_add_block_to_block (&se->pre, &lse.pre);
1337 gfc_init_se (&rse, se);
1338 gfc_conv_expr (&rse, expr->value.op.op2);
1339 gfc_add_block_to_block (&se->pre, &rse.pre);
1343 gfc_conv_string_parameter (&lse);
1344 gfc_conv_string_parameter (&rse);
1346 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1347 rse.string_length, rse.expr,
1348 expr->value.op.op1->ts.kind);
1349 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1350 gfc_add_block_to_block (&lse.post, &rse.post);
1353 type = gfc_typenode_for_spec (&expr->ts);
1357 /* The result of logical ops is always boolean_type_node. */
1358 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1359 se->expr = convert (type, tmp);
1362 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1364 /* Add the post blocks. */
1365 gfc_add_block_to_block (&se->post, &rse.post);
1366 gfc_add_block_to_block (&se->post, &lse.post);
1369 /* If a string's length is one, we convert it to a single character. */
1372 string_to_single_character (tree len, tree str, int kind)
1374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1376 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1377 && TREE_INT_CST_HIGH (len) == 0)
1379 str = fold_convert (gfc_get_pchar_type (kind), str);
1380 return build_fold_indirect_ref (str);
1388 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1391 if (sym->backend_decl)
1393 /* This becomes the nominal_type in
1394 function.c:assign_parm_find_data_types. */
1395 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1396 /* This becomes the passed_type in
1397 function.c:assign_parm_find_data_types. C promotes char to
1398 integer for argument passing. */
1399 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1401 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1406 /* If we have a constant character expression, make it into an
1408 if ((*expr)->expr_type == EXPR_CONSTANT)
1413 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1414 if ((*expr)->ts.kind != gfc_c_int_kind)
1416 /* The expr needs to be compatible with a C int. If the
1417 conversion fails, then the 2 causes an ICE. */
1418 ts.type = BT_INTEGER;
1419 ts.kind = gfc_c_int_kind;
1420 gfc_convert_type (*expr, &ts, 2);
1423 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1425 if ((*expr)->ref == NULL)
1427 se->expr = string_to_single_character
1428 (build_int_cst (integer_type_node, 1),
1429 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1431 ((*expr)->symtree->n.sym)),
1436 gfc_conv_variable (se, *expr);
1437 se->expr = string_to_single_character
1438 (build_int_cst (integer_type_node, 1),
1439 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1448 /* Compare two strings. If they are all single characters, the result is the
1449 subtraction of them. Otherwise, we build a library call. */
1452 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1458 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1459 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1461 sc1 = string_to_single_character (len1, str1, kind);
1462 sc2 = string_to_single_character (len2, str2, kind);
1464 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1466 /* Deal with single character specially. */
1467 sc1 = fold_convert (integer_type_node, sc1);
1468 sc2 = fold_convert (integer_type_node, sc2);
1469 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1473 /* Build a call for the comparison. */
1477 fndecl = gfor_fndecl_compare_string;
1479 fndecl = gfor_fndecl_compare_string_char4;
1483 tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
1490 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1494 if (sym->attr.dummy)
1496 tmp = gfc_get_symbol_decl (sym);
1497 if (sym->attr.proc_pointer)
1498 tmp = build_fold_indirect_ref (tmp);
1499 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1500 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1504 if (!sym->backend_decl)
1505 sym->backend_decl = gfc_get_extern_function_decl (sym);
1507 tmp = sym->backend_decl;
1508 if (sym->attr.cray_pointee)
1509 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1510 gfc_get_symbol_decl (sym->cp_pointer));
1511 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1513 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1514 tmp = build_fold_addr_expr (tmp);
1521 /* Translate the call for an elemental subroutine call used in an operator
1522 assignment. This is a simplified version of gfc_conv_function_call. */
1525 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1532 /* Only elemental subroutines with two arguments. */
1533 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1534 gcc_assert (sym->formal->next->next == NULL);
1536 gfc_init_block (&block);
1538 gfc_add_block_to_block (&block, &lse->pre);
1539 gfc_add_block_to_block (&block, &rse->pre);
1541 /* Build the argument list for the call, including hidden string lengths. */
1542 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1543 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1544 if (lse->string_length != NULL_TREE)
1545 args = gfc_chainon_list (args, lse->string_length);
1546 if (rse->string_length != NULL_TREE)
1547 args = gfc_chainon_list (args, rse->string_length);
1549 /* Build the function call. */
1550 gfc_init_se (&se, NULL);
1551 gfc_conv_function_val (&se, sym);
1552 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1553 tmp = build_call_list (tmp, se.expr, args);
1554 gfc_add_expr_to_block (&block, tmp);
1556 gfc_add_block_to_block (&block, &lse->post);
1557 gfc_add_block_to_block (&block, &rse->post);
1559 return gfc_finish_block (&block);
1563 /* Initialize MAPPING. */
1566 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1568 mapping->syms = NULL;
1569 mapping->charlens = NULL;
1573 /* Free all memory held by MAPPING (but not MAPPING itself). */
1576 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1578 gfc_interface_sym_mapping *sym;
1579 gfc_interface_sym_mapping *nextsym;
1581 gfc_charlen *nextcl;
1583 for (sym = mapping->syms; sym; sym = nextsym)
1585 nextsym = sym->next;
1586 gfc_free_symbol (sym->new_sym->n.sym);
1587 gfc_free_expr (sym->expr);
1588 gfc_free (sym->new_sym);
1591 for (cl = mapping->charlens; cl; cl = nextcl)
1594 gfc_free_expr (cl->length);
1600 /* Return a copy of gfc_charlen CL. Add the returned structure to
1601 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1603 static gfc_charlen *
1604 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1607 gfc_charlen *new_charlen;
1609 new_charlen = gfc_get_charlen ();
1610 new_charlen->next = mapping->charlens;
1611 new_charlen->length = gfc_copy_expr (cl->length);
1613 mapping->charlens = new_charlen;
1618 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1619 array variable that can be used as the actual argument for dummy
1620 argument SYM. Add any initialization code to BLOCK. PACKED is as
1621 for gfc_get_nodesc_array_type and DATA points to the first element
1622 in the passed array. */
1625 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1626 gfc_packed packed, tree data)
1631 type = gfc_typenode_for_spec (&sym->ts);
1632 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1634 var = gfc_create_var (type, "ifm");
1635 gfc_add_modify (block, var, fold_convert (type, data));
1641 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1642 and offset of descriptorless array type TYPE given that it has the same
1643 size as DESC. Add any set-up code to BLOCK. */
1646 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1653 offset = gfc_index_zero_node;
1654 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1656 dim = gfc_rank_cst[n];
1657 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1658 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1660 GFC_TYPE_ARRAY_LBOUND (type, n)
1661 = gfc_conv_descriptor_lbound (desc, dim);
1662 GFC_TYPE_ARRAY_UBOUND (type, n)
1663 = gfc_conv_descriptor_ubound (desc, dim);
1665 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1667 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1668 gfc_conv_descriptor_ubound (desc, dim),
1669 gfc_conv_descriptor_lbound (desc, dim));
1670 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1671 GFC_TYPE_ARRAY_LBOUND (type, n),
1673 tmp = gfc_evaluate_now (tmp, block);
1674 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1676 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1677 GFC_TYPE_ARRAY_LBOUND (type, n),
1678 GFC_TYPE_ARRAY_STRIDE (type, n));
1679 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1681 offset = gfc_evaluate_now (offset, block);
1682 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1686 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1687 in SE. The caller may still use se->expr and se->string_length after
1688 calling this function. */
1691 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1692 gfc_symbol * sym, gfc_se * se,
1695 gfc_interface_sym_mapping *sm;
1699 gfc_symbol *new_sym;
1701 gfc_symtree *new_symtree;
1703 /* Create a new symbol to represent the actual argument. */
1704 new_sym = gfc_new_symbol (sym->name, NULL);
1705 new_sym->ts = sym->ts;
1706 new_sym->as = gfc_copy_array_spec (sym->as);
1707 new_sym->attr.referenced = 1;
1708 new_sym->attr.dimension = sym->attr.dimension;
1709 new_sym->attr.pointer = sym->attr.pointer;
1710 new_sym->attr.allocatable = sym->attr.allocatable;
1711 new_sym->attr.flavor = sym->attr.flavor;
1712 new_sym->attr.function = sym->attr.function;
1714 /* Create a fake symtree for it. */
1716 new_symtree = gfc_new_symtree (&root, sym->name);
1717 new_symtree->n.sym = new_sym;
1718 gcc_assert (new_symtree == root);
1720 /* Create a dummy->actual mapping. */
1721 sm = XCNEW (gfc_interface_sym_mapping);
1722 sm->next = mapping->syms;
1724 sm->new_sym = new_symtree;
1725 sm->expr = gfc_copy_expr (expr);
1728 /* Stabilize the argument's value. */
1729 if (!sym->attr.function && se)
1730 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1732 if (sym->ts.type == BT_CHARACTER)
1734 /* Create a copy of the dummy argument's length. */
1735 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1736 sm->expr->ts.cl = new_sym->ts.cl;
1738 /* If the length is specified as "*", record the length that
1739 the caller is passing. We should use the callee's length
1740 in all other cases. */
1741 if (!new_sym->ts.cl->length && se)
1743 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1744 new_sym->ts.cl->backend_decl = se->string_length;
1751 /* Use the passed value as-is if the argument is a function. */
1752 if (sym->attr.flavor == FL_PROCEDURE)
1755 /* If the argument is either a string or a pointer to a string,
1756 convert it to a boundless character type. */
1757 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1759 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1760 tmp = build_pointer_type (tmp);
1761 if (sym->attr.pointer)
1762 value = build_fold_indirect_ref (se->expr);
1765 value = fold_convert (tmp, value);
1768 /* If the argument is a scalar, a pointer to an array or an allocatable,
1770 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1771 value = build_fold_indirect_ref (se->expr);
1773 /* For character(*), use the actual argument's descriptor. */
1774 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1775 value = build_fold_indirect_ref (se->expr);
1777 /* If the argument is an array descriptor, use it to determine
1778 information about the actual argument's shape. */
1779 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1780 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1782 /* Get the actual argument's descriptor. */
1783 desc = build_fold_indirect_ref (se->expr);
1785 /* Create the replacement variable. */
1786 tmp = gfc_conv_descriptor_data_get (desc);
1787 value = gfc_get_interface_mapping_array (&se->pre, sym,
1790 /* Use DESC to work out the upper bounds, strides and offset. */
1791 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1794 /* Otherwise we have a packed array. */
1795 value = gfc_get_interface_mapping_array (&se->pre, sym,
1796 PACKED_FULL, se->expr);
1798 new_sym->backend_decl = value;
1802 /* Called once all dummy argument mappings have been added to MAPPING,
1803 but before the mapping is used to evaluate expressions. Pre-evaluate
1804 the length of each argument, adding any initialization code to PRE and
1805 any finalization code to POST. */
1808 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1809 stmtblock_t * pre, stmtblock_t * post)
1811 gfc_interface_sym_mapping *sym;
1815 for (sym = mapping->syms; sym; sym = sym->next)
1816 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1817 && !sym->new_sym->n.sym->ts.cl->backend_decl)
1819 expr = sym->new_sym->n.sym->ts.cl->length;
1820 gfc_apply_interface_mapping_to_expr (mapping, expr);
1821 gfc_init_se (&se, NULL);
1822 gfc_conv_expr (&se, expr);
1824 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1825 gfc_add_block_to_block (pre, &se.pre);
1826 gfc_add_block_to_block (post, &se.post);
1828 sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
1833 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1837 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1838 gfc_constructor * c)
1840 for (; c; c = c->next)
1842 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1845 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1846 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1847 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1853 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1857 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1862 for (; ref; ref = ref->next)
1866 for (n = 0; n < ref->u.ar.dimen; n++)
1868 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1869 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1870 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1872 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1879 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1880 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1886 /* Convert intrinsic function calls into result expressions. */
1889 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1897 arg1 = expr->value.function.actual->expr;
1898 if (expr->value.function.actual->next)
1899 arg2 = expr->value.function.actual->next->expr;
1903 sym = arg1->symtree->n.sym;
1905 if (sym->attr.dummy)
1910 switch (expr->value.function.isym->id)
1913 /* TODO figure out why this condition is necessary. */
1914 if (sym->attr.function
1915 && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
1916 && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
1919 new_expr = gfc_copy_expr (arg1->ts.cl->length);
1926 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1928 dup = mpz_get_si (arg2->value.integer);
1933 dup = sym->as->rank;
1937 for (; d < dup; d++)
1941 if (!sym->as->upper[d] || !sym->as->lower[d])
1943 gfc_free_expr (new_expr);
1947 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1948 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1950 new_expr = gfc_multiply (new_expr, tmp);
1956 case GFC_ISYM_LBOUND:
1957 case GFC_ISYM_UBOUND:
1958 /* TODO These implementations of lbound and ubound do not limit if
1959 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1964 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1965 d = mpz_get_si (arg2->value.integer) - 1;
1967 /* TODO: If the need arises, this could produce an array of
1971 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1973 if (sym->as->lower[d])
1974 new_expr = gfc_copy_expr (sym->as->lower[d]);
1978 if (sym->as->upper[d])
1979 new_expr = gfc_copy_expr (sym->as->upper[d]);
1987 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
1991 gfc_replace_expr (expr, new_expr);
1997 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
1998 gfc_interface_mapping * mapping)
2000 gfc_formal_arglist *f;
2001 gfc_actual_arglist *actual;
2003 actual = expr->value.function.actual;
2004 f = map_expr->symtree->n.sym->formal;
2006 for (; f && actual; f = f->next, actual = actual->next)
2011 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2014 if (map_expr->symtree->n.sym->attr.dimension)
2019 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2021 for (d = 0; d < as->rank; d++)
2023 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2024 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2027 expr->value.function.esym->as = as;
2030 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2032 expr->value.function.esym->ts.cl->length
2033 = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
2035 gfc_apply_interface_mapping_to_expr (mapping,
2036 expr->value.function.esym->ts.cl->length);
2041 /* EXPR is a copy of an expression that appeared in the interface
2042 associated with MAPPING. Walk it recursively looking for references to
2043 dummy arguments that MAPPING maps to actual arguments. Replace each such
2044 reference with a reference to the associated actual argument. */
2047 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2050 gfc_interface_sym_mapping *sym;
2051 gfc_actual_arglist *actual;
2056 /* Copying an expression does not copy its length, so do that here. */
2057 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
2059 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
2060 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
2063 /* Apply the mapping to any references. */
2064 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2066 /* ...and to the expression's symbol, if it has one. */
2067 /* TODO Find out why the condition on expr->symtree had to be moved into
2068 the loop rather than being outside it, as originally. */
2069 for (sym = mapping->syms; sym; sym = sym->next)
2070 if (expr->symtree && sym->old == expr->symtree->n.sym)
2072 if (sym->new_sym->n.sym->backend_decl)
2073 expr->symtree = sym->new_sym;
2075 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2078 /* ...and to subexpressions in expr->value. */
2079 switch (expr->expr_type)
2084 case EXPR_SUBSTRING:
2088 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2089 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2093 for (actual = expr->value.function.actual; actual; actual = actual->next)
2094 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2096 if (expr->value.function.esym == NULL
2097 && expr->value.function.isym != NULL
2098 && expr->value.function.actual->expr->symtree
2099 && gfc_map_intrinsic_function (expr, mapping))
2102 for (sym = mapping->syms; sym; sym = sym->next)
2103 if (sym->old == expr->value.function.esym)
2105 expr->value.function.esym = sym->new_sym->n.sym;
2106 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2107 expr->value.function.esym->result = sym->new_sym->n.sym;
2112 case EXPR_STRUCTURE:
2113 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2125 /* Evaluate interface expression EXPR using MAPPING. Store the result
2129 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2130 gfc_se * se, gfc_expr * expr)
2132 expr = gfc_copy_expr (expr);
2133 gfc_apply_interface_mapping_to_expr (mapping, expr);
2134 gfc_conv_expr (se, expr);
2135 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2136 gfc_free_expr (expr);
2140 /* Returns a reference to a temporary array into which a component of
2141 an actual argument derived type array is copied and then returned
2142 after the function call. */
2144 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2145 int g77, sym_intent intent)
2161 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2163 gfc_init_se (&lse, NULL);
2164 gfc_init_se (&rse, NULL);
2166 /* Walk the argument expression. */
2167 rss = gfc_walk_expr (expr);
2169 gcc_assert (rss != gfc_ss_terminator);
2171 /* Initialize the scalarizer. */
2172 gfc_init_loopinfo (&loop);
2173 gfc_add_ss_to_loop (&loop, rss);
2175 /* Calculate the bounds of the scalarization. */
2176 gfc_conv_ss_startstride (&loop);
2178 /* Build an ss for the temporary. */
2179 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2180 gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
2182 base_type = gfc_typenode_for_spec (&expr->ts);
2183 if (GFC_ARRAY_TYPE_P (base_type)
2184 || GFC_DESCRIPTOR_TYPE_P (base_type))
2185 base_type = gfc_get_element_type (base_type);
2187 loop.temp_ss = gfc_get_ss ();;
2188 loop.temp_ss->type = GFC_SS_TEMP;
2189 loop.temp_ss->data.temp.type = base_type;
2191 if (expr->ts.type == BT_CHARACTER)
2192 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2194 loop.temp_ss->string_length = NULL;
2196 parmse->string_length = loop.temp_ss->string_length;
2197 loop.temp_ss->data.temp.dimen = loop.dimen;
2198 loop.temp_ss->next = gfc_ss_terminator;
2200 /* Associate the SS with the loop. */
2201 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2203 /* Setup the scalarizing loops. */
2204 gfc_conv_loop_setup (&loop, &expr->where);
2206 /* Pass the temporary descriptor back to the caller. */
2207 info = &loop.temp_ss->data.info;
2208 parmse->expr = info->descriptor;
2210 /* Setup the gfc_se structures. */
2211 gfc_copy_loopinfo_to_se (&lse, &loop);
2212 gfc_copy_loopinfo_to_se (&rse, &loop);
2215 lse.ss = loop.temp_ss;
2216 gfc_mark_ss_chain_used (rss, 1);
2217 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2219 /* Start the scalarized loop body. */
2220 gfc_start_scalarized_body (&loop, &body);
2222 /* Translate the expression. */
2223 gfc_conv_expr (&rse, expr);
2225 gfc_conv_tmp_array_ref (&lse);
2226 gfc_advance_se_ss_chain (&lse);
2228 if (intent != INTENT_OUT)
2230 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2231 gfc_add_expr_to_block (&body, tmp);
2232 gcc_assert (rse.ss == gfc_ss_terminator);
2233 gfc_trans_scalarizing_loops (&loop, &body);
2237 /* Make sure that the temporary declaration survives by merging
2238 all the loop declarations into the current context. */
2239 for (n = 0; n < loop.dimen; n++)
2241 gfc_merge_block_scope (&body);
2242 body = loop.code[loop.order[n]];
2244 gfc_merge_block_scope (&body);
2247 /* Add the post block after the second loop, so that any
2248 freeing of allocated memory is done at the right time. */
2249 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2251 /**********Copy the temporary back again.*********/
2253 gfc_init_se (&lse, NULL);
2254 gfc_init_se (&rse, NULL);
2256 /* Walk the argument expression. */
2257 lss = gfc_walk_expr (expr);
2258 rse.ss = loop.temp_ss;
2261 /* Initialize the scalarizer. */
2262 gfc_init_loopinfo (&loop2);
2263 gfc_add_ss_to_loop (&loop2, lss);
2265 /* Calculate the bounds of the scalarization. */
2266 gfc_conv_ss_startstride (&loop2);
2268 /* Setup the scalarizing loops. */
2269 gfc_conv_loop_setup (&loop2, &expr->where);
2271 gfc_copy_loopinfo_to_se (&lse, &loop2);
2272 gfc_copy_loopinfo_to_se (&rse, &loop2);
2274 gfc_mark_ss_chain_used (lss, 1);
2275 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2277 /* Declare the variable to hold the temporary offset and start the
2278 scalarized loop body. */
2279 offset = gfc_create_var (gfc_array_index_type, NULL);
2280 gfc_start_scalarized_body (&loop2, &body);
2282 /* Build the offsets for the temporary from the loop variables. The
2283 temporary array has lbounds of zero and strides of one in all
2284 dimensions, so this is very simple. The offset is only computed
2285 outside the innermost loop, so the overall transfer could be
2286 optimized further. */
2287 info = &rse.ss->data.info;
2289 tmp_index = gfc_index_zero_node;
2290 for (n = info->dimen - 1; n > 0; n--)
2293 tmp = rse.loop->loopvar[n];
2294 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2295 tmp, rse.loop->from[n]);
2296 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2299 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2300 rse.loop->to[n-1], rse.loop->from[n-1]);
2301 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2302 tmp_str, gfc_index_one_node);
2304 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2308 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2309 tmp_index, rse.loop->from[0]);
2310 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2312 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2313 rse.loop->loopvar[0], offset);
2315 /* Now use the offset for the reference. */
2316 tmp = build_fold_indirect_ref (info->data);
2317 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2319 if (expr->ts.type == BT_CHARACTER)
2320 rse.string_length = expr->ts.cl->backend_decl;
2322 gfc_conv_expr (&lse, expr);
2324 gcc_assert (lse.ss == gfc_ss_terminator);
2326 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2327 gfc_add_expr_to_block (&body, tmp);
2329 /* Generate the copying loops. */
2330 gfc_trans_scalarizing_loops (&loop2, &body);
2332 /* Wrap the whole thing up by adding the second loop to the post-block
2333 and following it by the post-block of the first loop. In this way,
2334 if the temporary needs freeing, it is done after use! */
2335 if (intent != INTENT_IN)
2337 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2338 gfc_add_block_to_block (&parmse->post, &loop2.post);
2341 gfc_add_block_to_block (&parmse->post, &loop.post);
2343 gfc_cleanup_loop (&loop);
2344 gfc_cleanup_loop (&loop2);
2346 /* Pass the string length to the argument expression. */
2347 if (expr->ts.type == BT_CHARACTER)
2348 parmse->string_length = expr->ts.cl->backend_decl;
2350 /* We want either the address for the data or the address of the descriptor,
2351 depending on the mode of passing array arguments. */
2353 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2355 parmse->expr = build_fold_addr_expr (parmse->expr);
2361 /* Generate the code for argument list functions. */
2364 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2366 /* Pass by value for g77 %VAL(arg), pass the address
2367 indirectly for %LOC, else by reference. Thus %REF
2368 is a "do-nothing" and %LOC is the same as an F95
2370 if (strncmp (name, "%VAL", 4) == 0)
2371 gfc_conv_expr (se, expr);
2372 else if (strncmp (name, "%LOC", 4) == 0)
2374 gfc_conv_expr_reference (se, expr);
2375 se->expr = gfc_build_addr_expr (NULL, se->expr);
2377 else if (strncmp (name, "%REF", 4) == 0)
2378 gfc_conv_expr_reference (se, expr);
2380 gfc_error ("Unknown argument list function at %L", &expr->where);
2384 /* Generate code for a procedure call. Note can return se->post != NULL.
2385 If se->direct_byref is set then se->expr contains the return parameter.
2386 Return nonzero, if the call has alternate specifiers. */
2389 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2390 gfc_actual_arglist * arg, tree append_args)
2392 gfc_interface_mapping mapping;
2406 gfc_formal_arglist *formal;
2407 int has_alternate_specifier = 0;
2408 bool need_interface_mapping;
2415 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2417 arglist = NULL_TREE;
2418 retargs = NULL_TREE;
2419 stringargs = NULL_TREE;
2424 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2426 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2428 if (arg->expr->rank == 0)
2429 gfc_conv_expr_reference (se, arg->expr);
2433 /* This is really the actual arg because no formal arglist is
2434 created for C_LOC. */
2435 fsym = arg->expr->symtree->n.sym;
2437 /* We should want it to do g77 calling convention. */
2439 && !(fsym->attr.pointer || fsym->attr.allocatable)
2440 && fsym->as->type != AS_ASSUMED_SHAPE;
2441 f = f || !sym->attr.always_explicit;
2443 argss = gfc_walk_expr (arg->expr);
2444 gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
2447 /* TODO -- the following two lines shouldn't be necessary, but
2448 they're removed a bug is exposed later in the codepath.
2449 This is workaround was thus introduced, but will have to be
2450 removed; please see PR 35150 for details about the issue. */
2451 se->expr = convert (pvoid_type_node, se->expr);
2452 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2456 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2458 arg->expr->ts.type = sym->ts.derived->ts.type;
2459 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2460 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2461 gfc_conv_expr_reference (se, arg->expr);
2465 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2466 && arg->next->expr->rank == 0)
2467 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2469 /* Convert c_f_pointer if fptr is a scalar
2470 and convert c_f_procpointer. */
2474 gfc_init_se (&cptrse, NULL);
2475 gfc_conv_expr (&cptrse, arg->expr);
2476 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2477 gfc_add_block_to_block (&se->post, &cptrse.post);
2479 gfc_init_se (&fptrse, NULL);
2480 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2481 fptrse.want_pointer = 1;
2483 gfc_conv_expr (&fptrse, arg->next->expr);
2484 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2485 gfc_add_block_to_block (&se->post, &fptrse.post);
2487 tmp = arg->next->expr->symtree->n.sym->backend_decl;
2488 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
2489 fold_convert (TREE_TYPE (tmp), cptrse.expr));
2493 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2498 /* Build the addr_expr for the first argument. The argument is
2499 already an *address* so we don't need to set want_pointer in
2501 gfc_init_se (&arg1se, NULL);
2502 gfc_conv_expr (&arg1se, arg->expr);
2503 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2504 gfc_add_block_to_block (&se->post, &arg1se.post);
2506 /* See if we were given two arguments. */
2507 if (arg->next == NULL)
2508 /* Only given one arg so generate a null and do a
2509 not-equal comparison against the first arg. */
2510 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2511 fold_convert (TREE_TYPE (arg1se.expr),
2512 null_pointer_node));
2518 /* Given two arguments so build the arg2se from second arg. */
2519 gfc_init_se (&arg2se, NULL);
2520 gfc_conv_expr (&arg2se, arg->next->expr);
2521 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2522 gfc_add_block_to_block (&se->post, &arg2se.post);
2524 /* Generate test to compare that the two args are equal. */
2525 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2526 arg1se.expr, arg2se.expr);
2527 /* Generate test to ensure that the first arg is not null. */
2528 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2529 arg1se.expr, null_pointer_node);
2531 /* Finally, the generated test must check that both arg1 is not
2532 NULL and that it is equal to the second arg. */
2533 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2534 not_null_expr, eq_expr);
2543 if (!sym->attr.elemental)
2545 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2546 if (se->ss->useflags)
2548 gcc_assert (gfc_return_by_reference (sym)
2549 && sym->result->attr.dimension);
2550 gcc_assert (se->loop != NULL);
2552 /* Access the previously obtained result. */
2553 gfc_conv_tmp_array_ref (se);
2554 gfc_advance_se_ss_chain (se);
2558 info = &se->ss->data.info;
2563 gfc_init_block (&post);
2564 gfc_init_interface_mapping (&mapping);
2565 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2566 && sym->ts.cl->length
2567 && sym->ts.cl->length->expr_type
2569 || sym->attr.dimension);
2570 formal = sym->formal;
2571 /* Evaluate the arguments. */
2572 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2575 fsym = formal ? formal->sym : NULL;
2576 parm_kind = MISSING;
2580 if (se->ignore_optional)
2582 /* Some intrinsics have already been resolved to the correct
2586 else if (arg->label)
2588 has_alternate_specifier = 1;
2593 /* Pass a NULL pointer for an absent arg. */
2594 gfc_init_se (&parmse, NULL);
2595 parmse.expr = null_pointer_node;
2596 if (arg->missing_arg_type == BT_CHARACTER)
2597 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2600 else if (se->ss && se->ss->useflags)
2602 /* An elemental function inside a scalarized loop. */
2603 gfc_init_se (&parmse, se);
2604 gfc_conv_expr_reference (&parmse, e);
2605 parm_kind = ELEMENTAL;
2609 /* A scalar or transformational function. */
2610 gfc_init_se (&parmse, NULL);
2611 argss = gfc_walk_expr (e);
2613 if (argss == gfc_ss_terminator)
2615 if (fsym && fsym->attr.value)
2617 if (fsym->ts.type == BT_CHARACTER
2618 && fsym->ts.is_c_interop
2619 && fsym->ns->proc_name != NULL
2620 && fsym->ns->proc_name->attr.is_bind_c)
2623 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2624 if (parmse.expr == NULL)
2625 gfc_conv_expr (&parmse, e);
2628 gfc_conv_expr (&parmse, e);
2630 else if (arg->name && arg->name[0] == '%')
2631 /* Argument list functions %VAL, %LOC and %REF are signalled
2632 through arg->name. */
2633 conv_arglist_function (&parmse, arg->expr, arg->name);
2634 else if ((e->expr_type == EXPR_FUNCTION)
2635 && e->symtree->n.sym->attr.pointer
2636 && fsym && fsym->attr.target)
2638 gfc_conv_expr (&parmse, e);
2639 parmse.expr = build_fold_addr_expr (parmse.expr);
2643 gfc_conv_expr_reference (&parmse, e);
2644 if (fsym && e->expr_type != EXPR_NULL
2645 && ((fsym->attr.pointer
2646 && fsym->attr.flavor != FL_PROCEDURE)
2647 || fsym->attr.proc_pointer))
2649 /* Scalar pointer dummy args require an extra level of
2650 indirection. The null pointer already contains
2651 this level of indirection. */
2652 parm_kind = SCALAR_POINTER;
2653 parmse.expr = build_fold_addr_expr (parmse.expr);
2659 /* If the procedure requires an explicit interface, the actual
2660 argument is passed according to the corresponding formal
2661 argument. If the corresponding formal argument is a POINTER,
2662 ALLOCATABLE or assumed shape, we do not use g77's calling
2663 convention, and pass the address of the array descriptor
2664 instead. Otherwise we use g77's calling convention. */
2667 && !(fsym->attr.pointer || fsym->attr.allocatable)
2668 && fsym->as->type != AS_ASSUMED_SHAPE;
2669 f = f || !sym->attr.always_explicit;
2671 if (e->expr_type == EXPR_VARIABLE
2672 && is_subref_array (e))
2673 /* The actual argument is a component reference to an
2674 array of derived types. In this case, the argument
2675 is converted to a temporary, which is passed and then
2676 written back after the procedure call. */
2677 gfc_conv_subref_array_arg (&parmse, e, f,
2678 fsym ? fsym->attr.intent : INTENT_INOUT);
2680 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2683 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2684 allocated on entry, it must be deallocated. */
2685 if (fsym && fsym->attr.allocatable
2686 && fsym->attr.intent == INTENT_OUT)
2688 tmp = build_fold_indirect_ref (parmse.expr);
2689 tmp = gfc_trans_dealloc_allocated (tmp);
2690 gfc_add_expr_to_block (&se->pre, tmp);
2696 /* The case with fsym->attr.optional is that of a user subroutine
2697 with an interface indicating an optional argument. When we call
2698 an intrinsic subroutine, however, fsym is NULL, but we might still
2699 have an optional argument, so we proceed to the substitution
2701 if (e && (fsym == NULL || fsym->attr.optional))
2703 /* If an optional argument is itself an optional dummy argument,
2704 check its presence and substitute a null if absent. */
2705 if (e->expr_type == EXPR_VARIABLE
2706 && e->symtree->n.sym->attr.optional)
2707 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2708 e->representation.length);
2713 /* Obtain the character length of an assumed character length
2714 length procedure from the typespec. */
2715 if (fsym->ts.type == BT_CHARACTER
2716 && parmse.string_length == NULL_TREE
2717 && e->ts.type == BT_PROCEDURE
2718 && e->symtree->n.sym->ts.type == BT_CHARACTER
2719 && e->symtree->n.sym->ts.cl->length != NULL
2720 && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
2722 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2723 parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2727 if (fsym && need_interface_mapping && e)
2728 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2730 gfc_add_block_to_block (&se->pre, &parmse.pre);
2731 gfc_add_block_to_block (&post, &parmse.post);
2733 /* Allocated allocatable components of derived types must be
2734 deallocated for INTENT(OUT) dummy arguments and non-variable
2735 scalars. Non-variable arrays are dealt with in trans-array.c
2736 (gfc_conv_array_parameter). */
2737 if (e && e->ts.type == BT_DERIVED
2738 && e->ts.derived->attr.alloc_comp
2739 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2741 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2744 tmp = build_fold_indirect_ref (parmse.expr);
2745 parm_rank = e->rank;
2753 case (SCALAR_POINTER):
2754 tmp = build_fold_indirect_ref (tmp);
2761 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2762 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2763 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2764 tmp, build_empty_stmt ());
2766 if (e->expr_type != EXPR_VARIABLE)
2767 /* Don't deallocate non-variables until they have been used. */
2768 gfc_add_expr_to_block (&se->post, tmp);
2771 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2772 gfc_add_expr_to_block (&se->pre, tmp);
2776 /* Character strings are passed as two parameters, a length and a
2777 pointer - except for Bind(c) which only passes the pointer. */
2778 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2779 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2781 arglist = gfc_chainon_list (arglist, parmse.expr);
2783 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2786 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2787 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2788 else if (ts.type == BT_CHARACTER)
2790 if (sym->ts.cl->length == NULL)
2792 /* Assumed character length results are not allowed by 5.1.1.5 of the
2793 standard and are trapped in resolve.c; except in the case of SPREAD
2794 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2795 we take the character length of the first argument for the result.
2796 For dummies, we have to look through the formal argument list for
2797 this function and use the character length found there.*/
2798 if (!sym->attr.dummy)
2799 cl.backend_decl = TREE_VALUE (stringargs);
2802 formal = sym->ns->proc_name->formal;
2803 for (; formal; formal = formal->next)
2804 if (strcmp (formal->sym->name, sym->name) == 0)
2805 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2812 /* Calculate the length of the returned string. */
2813 gfc_init_se (&parmse, NULL);
2814 if (need_interface_mapping)
2815 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2817 gfc_conv_expr (&parmse, sym->ts.cl->length);
2818 gfc_add_block_to_block (&se->pre, &parmse.pre);
2819 gfc_add_block_to_block (&se->post, &parmse.post);
2821 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2822 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2823 build_int_cst (gfc_charlen_type_node, 0));
2824 cl.backend_decl = tmp;
2827 /* Set up a charlen structure for it. */
2832 len = cl.backend_decl;
2835 byref = gfc_return_by_reference (sym);
2838 if (se->direct_byref)
2840 /* Sometimes, too much indirection can be applied; e.g. for
2841 function_result = array_valued_recursive_function. */
2842 if (TREE_TYPE (TREE_TYPE (se->expr))
2843 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2844 && GFC_DESCRIPTOR_TYPE_P
2845 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2846 se->expr = build_fold_indirect_ref (se->expr);
2848 retargs = gfc_chainon_list (retargs, se->expr);
2850 else if (sym->result->attr.dimension)
2852 gcc_assert (se->loop && info);
2854 /* Set the type of the array. */
2855 tmp = gfc_typenode_for_spec (&ts);
2856 info->dimen = se->loop->dimen;
2858 /* Evaluate the bounds of the result, if known. */
2859 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2861 /* Create a temporary to store the result. In case the function
2862 returns a pointer, the temporary will be a shallow copy and
2863 mustn't be deallocated. */
2864 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2865 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2866 false, !sym->attr.pointer, callee_alloc,
2867 &se->ss->expr->where);
2869 /* Pass the temporary as the first argument. */
2870 tmp = info->descriptor;
2871 tmp = build_fold_addr_expr (tmp);
2872 retargs = gfc_chainon_list (retargs, tmp);
2874 else if (ts.type == BT_CHARACTER)
2876 /* Pass the string length. */
2877 type = gfc_get_character_type (ts.kind, ts.cl);
2878 type = build_pointer_type (type);
2880 /* Return an address to a char[0:len-1]* temporary for
2881 character pointers. */
2882 if (sym->attr.pointer || sym->attr.allocatable)
2884 var = gfc_create_var (type, "pstr");
2886 /* Provide an address expression for the function arguments. */
2887 var = build_fold_addr_expr (var);
2890 var = gfc_conv_string_tmp (se, type, len);
2892 retargs = gfc_chainon_list (retargs, var);
2896 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2898 type = gfc_get_complex_type (ts.kind);
2899 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2900 retargs = gfc_chainon_list (retargs, var);
2903 /* Add the string length to the argument list. */
2904 if (ts.type == BT_CHARACTER)
2905 retargs = gfc_chainon_list (retargs, len);
2907 gfc_free_interface_mapping (&mapping);
2909 /* Add the return arguments. */
2910 arglist = chainon (retargs, arglist);
2912 /* Add the hidden string length parameters to the arguments. */
2913 arglist = chainon (arglist, stringargs);
2915 /* We may want to append extra arguments here. This is used e.g. for
2916 calls to libgfortran_matmul_??, which need extra information. */
2917 if (append_args != NULL_TREE)
2918 arglist = chainon (arglist, append_args);
2920 /* Generate the actual call. */
2921 gfc_conv_function_val (se, sym);
2923 /* If there are alternate return labels, function type should be
2924 integer. Can't modify the type in place though, since it can be shared
2925 with other functions. For dummy arguments, the typing is done to
2926 to this result, even if it has to be repeated for each call. */
2927 if (has_alternate_specifier
2928 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2930 if (!sym->attr.dummy)
2932 TREE_TYPE (sym->backend_decl)
2933 = build_function_type (integer_type_node,
2934 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2935 se->expr = build_fold_addr_expr (sym->backend_decl);
2938 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2941 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2942 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2944 /* If we have a pointer function, but we don't want a pointer, e.g.
2947 where f is pointer valued, we have to dereference the result. */
2948 if (!se->want_pointer && !byref && sym->attr.pointer)
2949 se->expr = build_fold_indirect_ref (se->expr);
2951 /* f2c calling conventions require a scalar default real function to
2952 return a double precision result. Convert this back to default
2953 real. We only care about the cases that can happen in Fortran 77.
2955 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2956 && sym->ts.kind == gfc_default_real_kind
2957 && !sym->attr.always_explicit)
2958 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2960 /* A pure function may still have side-effects - it may modify its
2962 TREE_SIDE_EFFECTS (se->expr) = 1;
2964 if (!sym->attr.pure)
2965 TREE_SIDE_EFFECTS (se->expr) = 1;
2970 /* Add the function call to the pre chain. There is no expression. */
2971 gfc_add_expr_to_block (&se->pre, se->expr);
2972 se->expr = NULL_TREE;
2974 if (!se->direct_byref)
2976 if (sym->attr.dimension)
2978 if (flag_bounds_check)
2980 /* Check the data pointer hasn't been modified. This would
2981 happen in a function returning a pointer. */
2982 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2983 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2985 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
2988 se->expr = info->descriptor;
2989 /* Bundle in the string length. */
2990 se->string_length = len;
2992 else if (sym->ts.type == BT_CHARACTER)
2994 /* Dereference for character pointer results. */
2995 if (sym->attr.pointer || sym->attr.allocatable)
2996 se->expr = build_fold_indirect_ref (var);
3000 se->string_length = len;
3004 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3005 se->expr = build_fold_indirect_ref (var);
3010 /* Follow the function call with the argument post block. */
3012 gfc_add_block_to_block (&se->pre, &post);
3014 gfc_add_block_to_block (&se->post, &post);
3016 return has_alternate_specifier;
3020 /* Fill a character string with spaces. */
3023 fill_with_spaces (tree start, tree type, tree size)
3025 stmtblock_t block, loop;
3026 tree i, el, exit_label, cond, tmp;
3028 /* For a simple char type, we can call memset(). */
3029 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3030 return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
3031 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3032 lang_hooks.to_target_charset (' ')),
3035 /* Otherwise, we use a loop:
3036 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3040 /* Initialize variables. */
3041 gfc_init_block (&block);
3042 i = gfc_create_var (sizetype, "i");
3043 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3044 el = gfc_create_var (build_pointer_type (type), "el");
3045 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3046 exit_label = gfc_build_label_decl (NULL_TREE);
3047 TREE_USED (exit_label) = 1;
3051 gfc_init_block (&loop);
3053 /* Exit condition. */
3054 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3055 fold_convert (sizetype, integer_zero_node));
3056 tmp = build1_v (GOTO_EXPR, exit_label);
3057 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3058 gfc_add_expr_to_block (&loop, tmp);
3061 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3062 build_int_cst (type,
3063 lang_hooks.to_target_charset (' ')));
3065 /* Increment loop variables. */
3066 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3067 TYPE_SIZE_UNIT (type)));
3068 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3070 TYPE_SIZE_UNIT (type)));
3072 /* Making the loop... actually loop! */
3073 tmp = gfc_finish_block (&loop);
3074 tmp = build1_v (LOOP_EXPR, tmp);
3075 gfc_add_expr_to_block (&block, tmp);
3077 /* The exit label. */
3078 tmp = build1_v (LABEL_EXPR, exit_label);
3079 gfc_add_expr_to_block (&block, tmp);
3082 return gfc_finish_block (&block);
3086 /* Generate code to copy a string. */
3089 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3090 int dkind, tree slength, tree src, int skind)
3092 tree tmp, dlen, slen;
3101 stmtblock_t tempblock;
3103 gcc_assert (dkind == skind);
3105 if (slength != NULL_TREE)
3107 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3108 ssc = string_to_single_character (slen, src, skind);
3112 slen = build_int_cst (size_type_node, 1);
3116 if (dlength != NULL_TREE)
3118 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3119 dsc = string_to_single_character (slen, dest, dkind);
3123 dlen = build_int_cst (size_type_node, 1);
3127 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3128 ssc = string_to_single_character (slen, src, skind);
3129 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3130 dsc = string_to_single_character (dlen, dest, dkind);
3133 /* Assign directly if the types are compatible. */
3134 if (dsc != NULL_TREE && ssc != NULL_TREE
3135 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3137 gfc_add_modify (block, dsc, ssc);
3141 /* Do nothing if the destination length is zero. */
3142 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3143 build_int_cst (size_type_node, 0));
3145 /* The following code was previously in _gfortran_copy_string:
3147 // The two strings may overlap so we use memmove.
3149 copy_string (GFC_INTEGER_4 destlen, char * dest,
3150 GFC_INTEGER_4 srclen, const char * src)
3152 if (srclen >= destlen)
3154 // This will truncate if too long.
3155 memmove (dest, src, destlen);
3159 memmove (dest, src, srclen);
3161 memset (&dest[srclen], ' ', destlen - srclen);
3165 We're now doing it here for better optimization, but the logic
3168 /* For non-default character kinds, we have to multiply the string
3169 length by the base type size. */
3170 chartype = gfc_get_char_type (dkind);
3171 slen = fold_build2 (MULT_EXPR, size_type_node,
3172 fold_convert (size_type_node, slen),
3173 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3174 dlen = fold_build2 (MULT_EXPR, size_type_node,
3175 fold_convert (size_type_node, dlen),
3176 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3179 dest = fold_convert (pvoid_type_node, dest);
3181 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3184 src = fold_convert (pvoid_type_node, src);
3186 src = gfc_build_addr_expr (pvoid_type_node, src);
3188 /* Truncate string if source is too long. */
3189 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3190 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3191 3, dest, src, dlen);
3193 /* Else copy and pad with spaces. */
3194 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3195 3, dest, src, slen);
3197 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3198 fold_convert (sizetype, slen));
3199 tmp4 = fill_with_spaces (tmp4, chartype,
3200 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3203 gfc_init_block (&tempblock);
3204 gfc_add_expr_to_block (&tempblock, tmp3);
3205 gfc_add_expr_to_block (&tempblock, tmp4);
3206 tmp3 = gfc_finish_block (&tempblock);
3208 /* The whole copy_string function is there. */
3209 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3210 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3211 gfc_add_expr_to_block (block, tmp);
3215 /* Translate a statement function.
3216 The value of a statement function reference is obtained by evaluating the
3217 expression using the values of the actual arguments for the values of the
3218 corresponding dummy arguments. */
3221 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3225 gfc_formal_arglist *fargs;
3226 gfc_actual_arglist *args;
3229 gfc_saved_var *saved_vars;
3235 sym = expr->symtree->n.sym;
3236 args = expr->value.function.actual;
3237 gfc_init_se (&lse, NULL);
3238 gfc_init_se (&rse, NULL);
3241 for (fargs = sym->formal; fargs; fargs = fargs->next)
3243 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3244 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3246 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3248 /* Each dummy shall be specified, explicitly or implicitly, to be
3250 gcc_assert (fargs->sym->attr.dimension == 0);
3253 /* Create a temporary to hold the value. */
3254 type = gfc_typenode_for_spec (&fsym->ts);
3255 temp_vars[n] = gfc_create_var (type, fsym->name);
3257 if (fsym->ts.type == BT_CHARACTER)
3259 /* Copy string arguments. */
3262 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3263 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3265 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3266 tmp = gfc_build_addr_expr (build_pointer_type (type),
3269 gfc_conv_expr (&rse, args->expr);
3270 gfc_conv_string_parameter (&rse);
3271 gfc_add_block_to_block (&se->pre, &lse.pre);
3272 gfc_add_block_to_block (&se->pre, &rse.pre);
3274 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3275 rse.string_length, rse.expr, fsym->ts.kind);
3276 gfc_add_block_to_block (&se->pre, &lse.post);
3277 gfc_add_block_to_block (&se->pre, &rse.post);
3281 /* For everything else, just evaluate the expression. */
3282 gfc_conv_expr (&lse, args->expr);
3284 gfc_add_block_to_block (&se->pre, &lse.pre);
3285 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3286 gfc_add_block_to_block (&se->pre, &lse.post);
3292 /* Use the temporary variables in place of the real ones. */
3293 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3294 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3296 gfc_conv_expr (se, sym->value);
3298 if (sym->ts.type == BT_CHARACTER)
3300 gfc_conv_const_charlen (sym->ts.cl);
3302 /* Force the expression to the correct length. */
3303 if (!INTEGER_CST_P (se->string_length)
3304 || tree_int_cst_lt (se->string_length,
3305 sym->ts.cl->backend_decl))
3307 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3308 tmp = gfc_create_var (type, sym->name);
3309 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3310 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3311 sym->ts.kind, se->string_length, se->expr,
3315 se->string_length = sym->ts.cl->backend_decl;
3318 /* Restore the original variables. */
3319 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3320 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3321 gfc_free (saved_vars);
3325 /* Translate a function expression. */
3328 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3332 if (expr->value.function.isym)
3334 gfc_conv_intrinsic_function (se, expr);
3338 /* We distinguish statement functions from general functions to improve
3339 runtime performance. */
3340 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3342 gfc_conv_statement_function (se, expr);
3346 /* expr.value.function.esym is the resolved (specific) function symbol for
3347 most functions. However this isn't set for dummy procedures. */
3348 sym = expr->value.function.esym;
3350 sym = expr->symtree->n.sym;
3351 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3356 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3358 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3359 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3361 gfc_conv_tmp_array_ref (se);
3362 gfc_advance_se_ss_chain (se);
3366 /* Build a static initializer. EXPR is the expression for the initial value.
3367 The other parameters describe the variable of the component being
3368 initialized. EXPR may be null. */
3371 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3372 bool array, bool pointer)
3376 if (!(expr || pointer))
3379 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3380 (these are the only two iso_c_binding derived types that can be
3381 used as initialization expressions). If so, we need to modify
3382 the 'expr' to be that for a (void *). */
3383 if (expr != NULL && expr->ts.type == BT_DERIVED
3384 && expr->ts.is_iso_c && expr->ts.derived)
3386 gfc_symbol *derived = expr->ts.derived;
3388 expr = gfc_int_expr (0);
3390 /* The derived symbol has already been converted to a (void *). Use
3392 expr->ts.f90_type = derived->ts.f90_type;
3393 expr->ts.kind = derived->ts.kind;
3398 /* Arrays need special handling. */
3400 return gfc_build_null_descriptor (type);
3402 return gfc_conv_array_initializer (type, expr);
3405 return fold_convert (type, null_pointer_node);
3411 gfc_init_se (&se, NULL);
3412 gfc_conv_structure (&se, expr, 1);
3416 return gfc_conv_string_init (ts->cl->backend_decl,expr);
3419 gfc_init_se (&se, NULL);
3420 gfc_conv_constant (&se, expr);
3427 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3439 gfc_start_block (&block);
3441 /* Initialize the scalarizer. */
3442 gfc_init_loopinfo (&loop);
3444 gfc_init_se (&lse, NULL);
3445 gfc_init_se (&rse, NULL);
3448 rss = gfc_walk_expr (expr);
3449 if (rss == gfc_ss_terminator)
3451 /* The rhs is scalar. Add a ss for the expression. */
3452 rss = gfc_get_ss ();
3453 rss->next = gfc_ss_terminator;
3454 rss->type = GFC_SS_SCALAR;
3458 /* Create a SS for the destination. */
3459 lss = gfc_get_ss ();
3460 lss->type = GFC_SS_COMPONENT;
3462 lss->shape = gfc_get_shape (cm->as->rank);
3463 lss->next = gfc_ss_terminator;
3464 lss->data.info.dimen = cm->as->rank;
3465 lss->data.info.descriptor = dest;
3466 lss->data.info.data = gfc_conv_array_data (dest);
3467 lss->data.info.offset = gfc_conv_array_offset (dest);
3468 for (n = 0; n < cm->as->rank; n++)
3470 lss->data.info.dim[n] = n;
3471 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3472 lss->data.info.stride[n] = gfc_index_one_node;
3474 mpz_init (lss->shape[n]);
3475 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3476 cm->as->lower[n]->value.integer);
3477 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3480 /* Associate the SS with the loop. */
3481 gfc_add_ss_to_loop (&loop, lss);
3482 gfc_add_ss_to_loop (&loop, rss);
3484 /* Calculate the bounds of the scalarization. */
3485 gfc_conv_ss_startstride (&loop);
3487 /* Setup the scalarizing loops. */
3488 gfc_conv_loop_setup (&loop, &expr->where);
3490 /* Setup the gfc_se structures. */
3491 gfc_copy_loopinfo_to_se (&lse, &loop);
3492 gfc_copy_loopinfo_to_se (&rse, &loop);
3495 gfc_mark_ss_chain_used (rss, 1);
3497 gfc_mark_ss_chain_used (lss, 1);
3499 /* Start the scalarized loop body. */
3500 gfc_start_scalarized_body (&loop, &body);
3502 gfc_conv_tmp_array_ref (&lse);
3503 if (cm->ts.type == BT_CHARACTER)
3504 lse.string_length = cm->ts.cl->backend_decl;
3506 gfc_conv_expr (&rse, expr);
3508 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3509 gfc_add_expr_to_block (&body, tmp);
3511 gcc_assert (rse.ss == gfc_ss_terminator);
3513 /* Generate the copying loops. */
3514 gfc_trans_scalarizing_loops (&loop, &body);
3516 /* Wrap the whole thing up. */
3517 gfc_add_block_to_block (&block, &loop.pre);
3518 gfc_add_block_to_block (&block, &loop.post);
3520 for (n = 0; n < cm->as->rank; n++)
3521 mpz_clear (lss->shape[n]);
3522 gfc_free (lss->shape);
3524 gfc_cleanup_loop (&loop);
3526 return gfc_finish_block (&block);
3530 /* Assign a single component of a derived type constructor. */
3533 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3543 gfc_start_block (&block);
3545 if (cm->attr.pointer)
3547 gfc_init_se (&se, NULL);
3548 /* Pointer component. */
3549 if (cm->attr.dimension)
3551 /* Array pointer. */
3552 if (expr->expr_type == EXPR_NULL)
3553 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3556 rss = gfc_walk_expr (expr);
3557 se.direct_byref = 1;
3559 gfc_conv_expr_descriptor (&se, expr, rss);
3560 gfc_add_block_to_block (&block, &se.pre);
3561 gfc_add_block_to_block (&block, &se.post);
3566 /* Scalar pointers. */
3567 se.want_pointer = 1;
3568 gfc_conv_expr (&se, expr);
3569 gfc_add_block_to_block (&block, &se.pre);
3570 gfc_add_modify (&block, dest,
3571 fold_convert (TREE_TYPE (dest), se.expr));
3572 gfc_add_block_to_block (&block, &se.post);
3575 else if (cm->attr.dimension)
3577 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3578 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3579 else if (cm->attr.allocatable)
3583 gfc_init_se (&se, NULL);
3585 rss = gfc_walk_expr (expr);
3586 se.want_pointer = 0;
3587 gfc_conv_expr_descriptor (&se, expr, rss);
3588 gfc_add_block_to_block (&block, &se.pre);
3590 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3591 gfc_add_modify (&block, dest, tmp);
3593 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3594 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3597 tmp = gfc_duplicate_allocatable (dest, se.expr,
3598 TREE_TYPE(cm->backend_decl),
3601 gfc_add_expr_to_block (&block, tmp);
3603 gfc_add_block_to_block (&block, &se.post);
3604 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3606 /* Shift the lbound and ubound of temporaries to being unity, rather
3607 than zero, based. Calculate the offset for all cases. */
3608 offset = gfc_conv_descriptor_offset (dest);
3609 gfc_add_modify (&block, offset, gfc_index_zero_node);
3610 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3611 for (n = 0; n < expr->rank; n++)
3613 if (expr->expr_type != EXPR_VARIABLE
3614 && expr->expr_type != EXPR_CONSTANT)
3617 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3618 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3619 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3620 gfc_add_modify (&block, tmp,
3621 fold_build2 (PLUS_EXPR,
3622 gfc_array_index_type,
3623 span, gfc_index_one_node));
3624 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3625 gfc_add_modify (&block, tmp, gfc_index_one_node);
3627 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3628 gfc_conv_descriptor_lbound (dest,
3630 gfc_conv_descriptor_stride (dest,
3632 gfc_add_modify (&block, tmp2, tmp);
3633 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3634 gfc_add_modify (&block, offset, tmp);
3639 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3640 gfc_add_expr_to_block (&block, tmp);
3643 else if (expr->ts.type == BT_DERIVED)
3645 if (expr->expr_type != EXPR_STRUCTURE)
3647 gfc_init_se (&se, NULL);
3648 gfc_conv_expr (&se, expr);
3649 gfc_add_modify (&block, dest,
3650 fold_convert (TREE_TYPE (dest), se.expr));
3654 /* Nested constructors. */
3655 tmp = gfc_trans_structure_assign (dest, expr);
3656 gfc_add_expr_to_block (&block, tmp);
3661 /* Scalar component. */
3662 gfc_init_se (&se, NULL);
3663 gfc_init_se (&lse, NULL);
3665 gfc_conv_expr (&se, expr);
3666 if (cm->ts.type == BT_CHARACTER)
3667 lse.string_length = cm->ts.cl->backend_decl;
3669 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3670 gfc_add_expr_to_block (&block, tmp);
3672 return gfc_finish_block (&block);
3675 /* Assign a derived type constructor to a variable. */
3678 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3686 gfc_start_block (&block);
3687 cm = expr->ts.derived->components;
3688 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3690 /* Skip absent members in default initializers. */
3694 /* Update the type/kind of the expression if it represents either
3695 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3696 be the first place reached for initializing output variables that
3697 have components of type C_PTR/C_FUNPTR that are initialized. */
3698 if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3699 && c->expr->ts.derived->attr.is_iso_c)
3701 c->expr->expr_type = EXPR_NULL;
3702 c->expr->ts.type = c->expr->ts.derived->ts.type;
3703 c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3704 c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3707 field = cm->backend_decl;
3708 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3709 dest, field, NULL_TREE);
3710 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3711 gfc_add_expr_to_block (&block, tmp);
3713 return gfc_finish_block (&block);
3716 /* Build an expression for a constructor. If init is nonzero then
3717 this is part of a static variable initializer. */
3720 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3727 VEC(constructor_elt,gc) *v = NULL;
3729 gcc_assert (se->ss == NULL);
3730 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3731 type = gfc_typenode_for_spec (&expr->ts);
3735 /* Create a temporary variable and fill it in. */
3736 se->expr = gfc_create_var (type, expr->ts.derived->name);
3737 tmp = gfc_trans_structure_assign (se->expr, expr);
3738 gfc_add_expr_to_block (&se->pre, tmp);
3742 cm = expr->ts.derived->components;
3744 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3746 /* Skip absent members in default initializers and allocatable
3747 components. Although the latter have a default initializer
3748 of EXPR_NULL,... by default, the static nullify is not needed
3749 since this is done every time we come into scope. */
3750 if (!c->expr || cm->attr.allocatable)
3753 val = gfc_conv_initializer (c->expr, &cm->ts,
3754 TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
3756 /* Append it to the constructor list. */
3757 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3759 se->expr = build_constructor (type, v);
3761 TREE_CONSTANT (se->expr) = 1;
3765 /* Translate a substring expression. */
3768 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3774 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3776 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3777 expr->value.character.length,
3778 expr->value.character.string);
3780 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3781 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3784 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3788 /* Entry point for expression translation. Evaluates a scalar quantity.
3789 EXPR is the expression to be translated, and SE is the state structure if
3790 called from within the scalarized. */
3793 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3795 if (se->ss && se->ss->expr == expr
3796 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3798 /* Substitute a scalar expression evaluated outside the scalarization
3800 se->expr = se->ss->data.scalar.expr;
3801 se->string_length = se->ss->string_length;
3802 gfc_advance_se_ss_chain (se);
3806 /* We need to convert the expressions for the iso_c_binding derived types.
3807 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3808 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3809 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3810 updated to be an integer with a kind equal to the size of a (void *). */
3811 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3812 && expr->ts.derived->attr.is_iso_c)
3814 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3815 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3817 /* Set expr_type to EXPR_NULL, which will result in
3818 null_pointer_node being used below. */
3819 expr->expr_type = EXPR_NULL;
3823 /* Update the type/kind of the expression to be what the new
3824 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3825 expr->ts.type = expr->ts.derived->ts.type;
3826 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3827 expr->ts.kind = expr->ts.derived->ts.kind;
3831 switch (expr->expr_type)
3834 gfc_conv_expr_op (se, expr);
3838 gfc_conv_function_expr (se, expr);
3842 gfc_conv_constant (se, expr);
3846 gfc_conv_variable (se, expr);
3850 se->expr = null_pointer_node;
3853 case EXPR_SUBSTRING:
3854 gfc_conv_substring_expr (se, expr);
3857 case EXPR_STRUCTURE:
3858 gfc_conv_structure (se, expr, 0);
3862 gfc_conv_array_constructor_expr (se, expr);
3871 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3872 of an assignment. */
3874 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3876 gfc_conv_expr (se, expr);
3877 /* All numeric lvalues should have empty post chains. If not we need to
3878 figure out a way of rewriting an lvalue so that it has no post chain. */
3879 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3882 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3883 numeric expressions. Used for scalar values where inserting cleanup code
3886 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3890 gcc_assert (expr->ts.type != BT_CHARACTER);
3891 gfc_conv_expr (se, expr);
3894 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3895 gfc_add_modify (&se->pre, val, se->expr);
3897 gfc_add_block_to_block (&se->pre, &se->post);
3901 /* Helper to translate an expression and convert it to a particular type. */
3903 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3905 gfc_conv_expr_val (se, expr);
3906 se->expr = convert (type, se->expr);
3910 /* Converts an expression so that it can be passed by reference. Scalar
3914 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3918 if (se->ss && se->ss->expr == expr
3919 && se->ss->type == GFC_SS_REFERENCE)
3921 se->expr = se->ss->data.scalar.expr;
3922 se->string_length = se->ss->string_length;
3923 gfc_advance_se_ss_chain (se);
3927 if (expr->ts.type == BT_CHARACTER)
3929 gfc_conv_expr (se, expr);
3930 gfc_conv_string_parameter (se);
3934 if (expr->expr_type == EXPR_VARIABLE)
3936 se->want_pointer = 1;
3937 gfc_conv_expr (se, expr);
3940 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3941 gfc_add_modify (&se->pre, var, se->expr);
3942 gfc_add_block_to_block (&se->pre, &se->post);
3948 if (expr->expr_type == EXPR_FUNCTION
3949 && expr->symtree->n.sym->attr.pointer
3950 && !expr->symtree->n.sym->attr.dimension)
3952 se->want_pointer = 1;
3953 gfc_conv_expr (se, expr);
3954 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3955 gfc_add_modify (&se->pre, var, se->expr);
3961 gfc_conv_expr (se, expr);
3963 /* Create a temporary var to hold the value. */
3964 if (TREE_CONSTANT (se->expr))
3966 tree tmp = se->expr;
3967 STRIP_TYPE_NOPS (tmp);
3968 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3969 DECL_INITIAL (var) = tmp;
3970 TREE_STATIC (var) = 1;
3975 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3976 gfc_add_modify (&se->pre, var, se->expr);
3978 gfc_add_block_to_block (&se->pre, &se->post);
3980 /* Take the address of that value. */
3981 se->expr = build_fold_addr_expr (var);
3986 gfc_trans_pointer_assign (gfc_code * code)
3988 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3992 /* Generate code for a pointer assignment. */
3995 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4007 gfc_start_block (&block);
4009 gfc_init_se (&lse, NULL);
4011 lss = gfc_walk_expr (expr1);
4012 rss = gfc_walk_expr (expr2);
4013 if (lss == gfc_ss_terminator)
4015 /* Scalar pointers. */
4016 lse.want_pointer = 1;
4017 gfc_conv_expr (&lse, expr1);
4018 gcc_assert (rss == gfc_ss_terminator);
4019 gfc_init_se (&rse, NULL);
4020 rse.want_pointer = 1;
4021 gfc_conv_expr (&rse, expr2);
4023 if (expr1->symtree->n.sym->attr.proc_pointer
4024 && expr1->symtree->n.sym->attr.dummy)
4025 lse.expr = build_fold_indirect_ref (lse.expr);
4027 gfc_add_block_to_block (&block, &lse.pre);
4028 gfc_add_block_to_block (&block, &rse.pre);
4029 gfc_add_modify (&block, lse.expr,
4030 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4031 gfc_add_block_to_block (&block, &rse.post);
4032 gfc_add_block_to_block (&block, &lse.post);
4036 /* Array pointer. */
4037 gfc_conv_expr_descriptor (&lse, expr1, lss);
4038 switch (expr2->expr_type)
4041 /* Just set the data pointer to null. */
4042 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4046 /* Assign directly to the pointer's descriptor. */
4047 lse.direct_byref = 1;
4048 gfc_conv_expr_descriptor (&lse, expr2, rss);
4050 /* If this is a subreference array pointer assignment, use the rhs
4051 descriptor element size for the lhs span. */
4052 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4054 decl = expr1->symtree->n.sym->backend_decl;
4055 gfc_init_se (&rse, NULL);
4056 rse.descriptor_only = 1;
4057 gfc_conv_expr (&rse, expr2);
4058 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4059 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4060 if (!INTEGER_CST_P (tmp))
4061 gfc_add_block_to_block (&lse.post, &rse.pre);
4062 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4068 /* Assign to a temporary descriptor and then copy that
4069 temporary to the pointer. */
4071 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4074 lse.direct_byref = 1;
4075 gfc_conv_expr_descriptor (&lse, expr2, rss);
4076 gfc_add_modify (&lse.pre, desc, tmp);
4079 gfc_add_block_to_block (&block, &lse.pre);
4080 gfc_add_block_to_block (&block, &lse.post);
4082 return gfc_finish_block (&block);
4086 /* Makes sure se is suitable for passing as a function string parameter. */
4087 /* TODO: Need to check all callers of this function. It may be abused. */
4090 gfc_conv_string_parameter (gfc_se * se)
4094 if (TREE_CODE (se->expr) == STRING_CST)
4096 type = TREE_TYPE (TREE_TYPE (se->expr));
4097 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4101 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4103 if (TREE_CODE (se->expr) != INDIRECT_REF)
4105 type = TREE_TYPE (se->expr);
4106 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4110 type = gfc_get_character_type_len (gfc_default_character_kind,
4112 type = build_pointer_type (type);
4113 se->expr = gfc_build_addr_expr (type, se->expr);
4117 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4118 gcc_assert (se->string_length
4119 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4123 /* Generate code for assignment of scalar variables. Includes character
4124 strings and derived types with allocatable components. */
4127 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4128 bool l_is_temp, bool r_is_var)
4134 gfc_init_block (&block);
4136 if (ts.type == BT_CHARACTER)
4141 if (lse->string_length != NULL_TREE)
4143 gfc_conv_string_parameter (lse);
4144 gfc_add_block_to_block (&block, &lse->pre);
4145 llen = lse->string_length;
4148 if (rse->string_length != NULL_TREE)
4150 gcc_assert (rse->string_length != NULL_TREE);
4151 gfc_conv_string_parameter (rse);
4152 gfc_add_block_to_block (&block, &rse->pre);
4153 rlen = rse->string_length;
4156 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4157 rse->expr, ts.kind);
4159 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4163 /* Are the rhs and the lhs the same? */
4166 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4167 build_fold_addr_expr (lse->expr),
4168 build_fold_addr_expr (rse->expr));
4169 cond = gfc_evaluate_now (cond, &lse->pre);
4172 /* Deallocate the lhs allocated components as long as it is not
4173 the same as the rhs. This must be done following the assignment
4174 to prevent deallocating data that could be used in the rhs
4178 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4179 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4181 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4182 gfc_add_expr_to_block (&lse->post, tmp);
4185 gfc_add_block_to_block (&block, &rse->pre);
4186 gfc_add_block_to_block (&block, &lse->pre);
4188 gfc_add_modify (&block, lse->expr,
4189 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4191 /* Do a deep copy if the rhs is a variable, if it is not the
4195 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4196 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4197 gfc_add_expr_to_block (&block, tmp);
4202 gfc_add_block_to_block (&block, &lse->pre);
4203 gfc_add_block_to_block (&block, &rse->pre);
4205 gfc_add_modify (&block, lse->expr,
4206 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4209 gfc_add_block_to_block (&block, &lse->post);
4210 gfc_add_block_to_block (&block, &rse->post);
4212 return gfc_finish_block (&block);
4216 /* Try to translate array(:) = func (...), where func is a transformational
4217 array function, without using a temporary. Returns NULL is this isn't the
4221 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4226 bool seen_array_ref;
4228 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4229 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4232 /* Elemental functions don't need a temporary anyway. */
4233 if (expr2->value.function.esym != NULL
4234 && expr2->value.function.esym->attr.elemental)
4237 /* Fail if EXPR1 can't be expressed as a descriptor. */
4238 if (gfc_ref_needs_temporary_p (expr1->ref))
4241 /* Functions returning pointers need temporaries. */
4242 if (expr2->symtree->n.sym->attr.pointer
4243 || expr2->symtree->n.sym->attr.allocatable)
4246 /* Character array functions need temporaries unless the
4247 character lengths are the same. */
4248 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4250 if (expr1->ts.cl->length == NULL
4251 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4254 if (expr2->ts.cl->length == NULL
4255 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4258 if (mpz_cmp (expr1->ts.cl->length->value.integer,
4259 expr2->ts.cl->length->value.integer) != 0)
4263 /* Check that no LHS component references appear during an array
4264 reference. This is needed because we do not have the means to
4265 span any arbitrary stride with an array descriptor. This check
4266 is not needed for the rhs because the function result has to be
4268 seen_array_ref = false;
4269 for (ref = expr1->ref; ref; ref = ref->next)
4271 if (ref->type == REF_ARRAY)
4272 seen_array_ref= true;
4273 else if (ref->type == REF_COMPONENT && seen_array_ref)
4277 /* Check for a dependency. */
4278 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4279 expr2->value.function.esym,
4280 expr2->value.function.actual))
4283 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4285 gcc_assert (expr2->value.function.isym
4286 || (gfc_return_by_reference (expr2->value.function.esym)
4287 && expr2->value.function.esym->result->attr.dimension));
4289 ss = gfc_walk_expr (expr1);
4290 gcc_assert (ss != gfc_ss_terminator);
4291 gfc_init_se (&se, NULL);
4292 gfc_start_block (&se.pre);
4293 se.want_pointer = 1;
4295 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
4297 se.direct_byref = 1;
4298 se.ss = gfc_walk_expr (expr2);
4299 gcc_assert (se.ss != gfc_ss_terminator);
4300 gfc_conv_function_expr (&se, expr2);
4301 gfc_add_block_to_block (&se.pre, &se.post);
4303 return gfc_finish_block (&se.pre);
4306 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4309 is_zero_initializer_p (gfc_expr * expr)
4311 if (expr->expr_type != EXPR_CONSTANT)
4314 /* We ignore constants with prescribed memory representations for now. */
4315 if (expr->representation.string)
4318 switch (expr->ts.type)
4321 return mpz_cmp_si (expr->value.integer, 0) == 0;
4324 return mpfr_zero_p (expr->value.real)
4325 && MPFR_SIGN (expr->value.real) >= 0;
4328 return expr->value.logical == 0;
4331 return mpfr_zero_p (expr->value.complex.r)
4332 && MPFR_SIGN (expr->value.complex.r) >= 0
4333 && mpfr_zero_p (expr->value.complex.i)
4334 && MPFR_SIGN (expr->value.complex.i) >= 0;
4342 /* Try to efficiently translate array(:) = 0. Return NULL if this
4346 gfc_trans_zero_assign (gfc_expr * expr)
4348 tree dest, len, type;
4352 sym = expr->symtree->n.sym;
4353 dest = gfc_get_symbol_decl (sym);
4355 type = TREE_TYPE (dest);
4356 if (POINTER_TYPE_P (type))
4357 type = TREE_TYPE (type);
4358 if (!GFC_ARRAY_TYPE_P (type))
4361 /* Determine the length of the array. */
4362 len = GFC_TYPE_ARRAY_SIZE (type);
4363 if (!len || TREE_CODE (len) != INTEGER_CST)
4366 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4367 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4368 fold_convert (gfc_array_index_type, tmp));
4370 /* Convert arguments to the correct types. */
4371 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4372 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4374 dest = fold_convert (pvoid_type_node, dest);
4375 len = fold_convert (size_type_node, len);
4377 /* Construct call to __builtin_memset. */
4378 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4379 3, dest, integer_zero_node, len);
4380 return fold_convert (void_type_node, tmp);
4384 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4385 that constructs the call to __builtin_memcpy. */
4388 gfc_build_memcpy_call (tree dst, tree src, tree len)
4392 /* Convert arguments to the correct types. */
4393 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4394 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4396 dst = fold_convert (pvoid_type_node, dst);
4398 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4399 src = gfc_build_addr_expr (pvoid_type_node, src);
4401 src = fold_convert (pvoid_type_node, src);
4403 len = fold_convert (size_type_node, len);
4405 /* Construct call to __builtin_memcpy. */
4406 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4407 return fold_convert (void_type_node, tmp);
4411 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4412 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4413 source/rhs, both are gfc_full_array_ref_p which have been checked for
4417 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4419 tree dst, dlen, dtype;
4420 tree src, slen, stype;
4423 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4424 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4426 dtype = TREE_TYPE (dst);
4427 if (POINTER_TYPE_P (dtype))
4428 dtype = TREE_TYPE (dtype);
4429 stype = TREE_TYPE (src);
4430 if (POINTER_TYPE_P (stype))
4431 stype = TREE_TYPE (stype);
4433 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4436 /* Determine the lengths of the arrays. */
4437 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4438 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4440 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4441 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4442 fold_convert (gfc_array_index_type, tmp));
4444 slen = GFC_TYPE_ARRAY_SIZE (stype);
4445 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4447 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4448 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4449 fold_convert (gfc_array_index_type, tmp));
4451 /* Sanity check that they are the same. This should always be
4452 the case, as we should already have checked for conformance. */
4453 if (!tree_int_cst_equal (slen, dlen))
4456 return gfc_build_memcpy_call (dst, src, dlen);
4460 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4461 this can't be done. EXPR1 is the destination/lhs for which
4462 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4465 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4467 unsigned HOST_WIDE_INT nelem;
4473 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4477 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4478 dtype = TREE_TYPE (dst);
4479 if (POINTER_TYPE_P (dtype))
4480 dtype = TREE_TYPE (dtype);
4481 if (!GFC_ARRAY_TYPE_P (dtype))
4484 /* Determine the lengths of the array. */
4485 len = GFC_TYPE_ARRAY_SIZE (dtype);
4486 if (!len || TREE_CODE (len) != INTEGER_CST)
4489 /* Confirm that the constructor is the same size. */
4490 if (compare_tree_int (len, nelem) != 0)
4493 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4494 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4495 fold_convert (gfc_array_index_type, tmp));
4497 stype = gfc_typenode_for_spec (&expr2->ts);
4498 src = gfc_build_constant_array_constructor (expr2, stype);
4500 stype = TREE_TYPE (src);
4501 if (POINTER_TYPE_P (stype))
4502 stype = TREE_TYPE (stype);
4504 return gfc_build_memcpy_call (dst, src, len);
4508 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4509 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4512 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4517 gfc_ss *lss_section;
4525 /* Assignment of the form lhs = rhs. */
4526 gfc_start_block (&block);
4528 gfc_init_se (&lse, NULL);
4529 gfc_init_se (&rse, NULL);
4532 lss = gfc_walk_expr (expr1);
4534 if (lss != gfc_ss_terminator)
4536 /* The assignment needs scalarization. */
4539 /* Find a non-scalar SS from the lhs. */
4540 while (lss_section != gfc_ss_terminator
4541 && lss_section->type != GFC_SS_SECTION)
4542 lss_section = lss_section->next;
4544 gcc_assert (lss_section != gfc_ss_terminator);
4546 /* Initialize the scalarizer. */
4547 gfc_init_loopinfo (&loop);
4550 rss = gfc_walk_expr (expr2);
4551 if (rss == gfc_ss_terminator)
4553 /* The rhs is scalar. Add a ss for the expression. */
4554 rss = gfc_get_ss ();
4555 rss->next = gfc_ss_terminator;
4556 rss->type = GFC_SS_SCALAR;
4559 /* Associate the SS with the loop. */
4560 gfc_add_ss_to_loop (&loop, lss);
4561 gfc_add_ss_to_loop (&loop, rss);
4563 /* Calculate the bounds of the scalarization. */
4564 gfc_conv_ss_startstride (&loop);
4565 /* Resolve any data dependencies in the statement. */
4566 gfc_conv_resolve_dependencies (&loop, lss, rss);
4567 /* Setup the scalarizing loops. */
4568 gfc_conv_loop_setup (&loop, &expr2->where);
4570 /* Setup the gfc_se structures. */
4571 gfc_copy_loopinfo_to_se (&lse, &loop);
4572 gfc_copy_loopinfo_to_se (&rse, &loop);
4575 gfc_mark_ss_chain_used (rss, 1);
4576 if (loop.temp_ss == NULL)
4579 gfc_mark_ss_chain_used (lss, 1);
4583 lse.ss = loop.temp_ss;
4584 gfc_mark_ss_chain_used (lss, 3);
4585 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4588 /* Start the scalarized loop body. */
4589 gfc_start_scalarized_body (&loop, &body);
4592 gfc_init_block (&body);
4594 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4596 /* Translate the expression. */
4597 gfc_conv_expr (&rse, expr2);
4601 gfc_conv_tmp_array_ref (&lse);
4602 gfc_advance_se_ss_chain (&lse);
4605 gfc_conv_expr (&lse, expr1);
4607 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4608 l_is_temp || init_flag,
4609 expr2->expr_type == EXPR_VARIABLE);
4610 gfc_add_expr_to_block (&body, tmp);
4612 if (lss == gfc_ss_terminator)
4614 /* Use the scalar assignment as is. */
4615 gfc_add_block_to_block (&block, &body);
4619 gcc_assert (lse.ss == gfc_ss_terminator
4620 && rse.ss == gfc_ss_terminator);
4624 gfc_trans_scalarized_loop_boundary (&loop, &body);
4626 /* We need to copy the temporary to the actual lhs. */
4627 gfc_init_se (&lse, NULL);
4628 gfc_init_se (&rse, NULL);
4629 gfc_copy_loopinfo_to_se (&lse, &loop);
4630 gfc_copy_loopinfo_to_se (&rse, &loop);
4632 rse.ss = loop.temp_ss;
4635 gfc_conv_tmp_array_ref (&rse);
4636 gfc_advance_se_ss_chain (&rse);
4637 gfc_conv_expr (&lse, expr1);
4639 gcc_assert (lse.ss == gfc_ss_terminator
4640 && rse.ss == gfc_ss_terminator);
4642 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4644 gfc_add_expr_to_block (&body, tmp);
4647 /* Generate the copying loops. */
4648 gfc_trans_scalarizing_loops (&loop, &body);
4650 /* Wrap the whole thing up. */
4651 gfc_add_block_to_block (&block, &loop.pre);
4652 gfc_add_block_to_block (&block, &loop.post);
4654 gfc_cleanup_loop (&loop);
4657 return gfc_finish_block (&block);
4661 /* Check whether EXPR is a copyable array. */
4664 copyable_array_p (gfc_expr * expr)
4666 if (expr->expr_type != EXPR_VARIABLE)
4669 /* First check it's an array. */
4670 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4673 if (!gfc_full_array_ref_p (expr->ref))
4676 /* Next check that it's of a simple enough type. */
4677 switch (expr->ts.type)
4689 return !expr->ts.derived->attr.alloc_comp;
4698 /* Translate an assignment. */
4701 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4705 /* Special case a single function returning an array. */
4706 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4708 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4713 /* Special case assigning an array to zero. */
4714 if (copyable_array_p (expr1)
4715 && is_zero_initializer_p (expr2))
4717 tmp = gfc_trans_zero_assign (expr1);
4722 /* Special case copying one array to another. */
4723 if (copyable_array_p (expr1)
4724 && copyable_array_p (expr2)
4725 && gfc_compare_types (&expr1->ts, &expr2->ts)
4726 && !gfc_check_dependency (expr1, expr2, 0))
4728 tmp = gfc_trans_array_copy (expr1, expr2);
4733 /* Special case initializing an array from a constant array constructor. */
4734 if (copyable_array_p (expr1)
4735 && expr2->expr_type == EXPR_ARRAY
4736 && gfc_compare_types (&expr1->ts, &expr2->ts))
4738 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4743 /* Fallback to the scalarizer to generate explicit loops. */
4744 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4748 gfc_trans_init_assign (gfc_code * code)
4750 return gfc_trans_assignment (code->expr, code->expr2, true);
4754 gfc_trans_assign (gfc_code * code)
4756 return gfc_trans_assignment (code->expr, code->expr2, false);