1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 = gfc_build_addr_expr (NULL_TREE, 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 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
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.proc_pointer) && c->attr.dimension == 0
480 && c->ts.type != BT_CHARACTER)
481 se->expr = build_fold_indirect_ref (se->expr);
485 /* This function deals with component references to components of the
486 parent type for derived type extensons. */
488 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
496 c = ref->u.c.component;
498 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
499 parent.type = REF_COMPONENT;
502 parent.u.c.component = dt->components;
504 if (dt->attr.extension && dt->components)
506 /* Return if the component is not in the parent type. */
507 for (cmp = dt->components->next; cmp; cmp = cmp->next)
508 if (strcmp (c->name, cmp->name) == 0)
511 /* Otherwise build the reference and call self. */
512 gfc_conv_component_ref (se, &parent);
513 parent.u.c.sym = dt->components->ts.derived;
514 parent.u.c.component = c;
515 conv_parent_component_references (se, &parent);
519 /* Return the contents of a variable. Also handles reference/pointer
520 variables (all Fortran pointer references are implicit). */
523 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
530 bool alternate_entry;
533 sym = expr->symtree->n.sym;
536 /* Check that something hasn't gone horribly wrong. */
537 gcc_assert (se->ss != gfc_ss_terminator);
538 gcc_assert (se->ss->expr == expr);
540 /* A scalarized term. We already know the descriptor. */
541 se->expr = se->ss->data.info.descriptor;
542 se->string_length = se->ss->string_length;
543 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
544 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
549 tree se_expr = NULL_TREE;
551 se->expr = gfc_get_symbol_decl (sym);
553 /* Deal with references to a parent results or entries by storing
554 the current_function_decl and moving to the parent_decl. */
555 return_value = sym->attr.function && sym->result == sym;
556 alternate_entry = sym->attr.function && sym->attr.entry
557 && sym->result == sym;
558 entry_master = sym->attr.result
559 && sym->ns->proc_name->attr.entry_master
560 && !gfc_return_by_reference (sym->ns->proc_name);
561 parent_decl = DECL_CONTEXT (current_function_decl);
563 if ((se->expr == parent_decl && return_value)
564 || (sym->ns && sym->ns->proc_name
566 && sym->ns->proc_name->backend_decl == parent_decl
567 && (alternate_entry || entry_master)))
572 /* Special case for assigning the return value of a function.
573 Self recursive functions must have an explicit return value. */
574 if (return_value && (se->expr == current_function_decl || parent_flag))
575 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
577 /* Similarly for alternate entry points. */
578 else if (alternate_entry
579 && (sym->ns->proc_name->backend_decl == current_function_decl
582 gfc_entry_list *el = NULL;
584 for (el = sym->ns->entries; el; el = el->next)
587 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
592 else if (entry_master
593 && (sym->ns->proc_name->backend_decl == current_function_decl
595 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
600 /* Procedure actual arguments. */
601 else if (sym->attr.flavor == FL_PROCEDURE
602 && se->expr != current_function_decl)
604 if (!sym->attr.dummy && !sym->attr.proc_pointer)
606 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
607 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
613 /* Dereference the expression, where needed. Since characters
614 are entirely different from other types, they are treated
616 if (sym->ts.type == BT_CHARACTER)
618 /* Dereference character pointer dummy arguments
620 if ((sym->attr.pointer || sym->attr.allocatable)
622 || sym->attr.function
623 || sym->attr.result))
624 se->expr = build_fold_indirect_ref (se->expr);
627 else if (!sym->attr.value)
629 /* Dereference non-character scalar dummy arguments. */
630 if (sym->attr.dummy && !sym->attr.dimension)
631 se->expr = build_fold_indirect_ref (se->expr);
633 /* Dereference scalar hidden result. */
634 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
635 && (sym->attr.function || sym->attr.result)
636 && !sym->attr.dimension && !sym->attr.pointer
637 && !sym->attr.always_explicit)
638 se->expr = build_fold_indirect_ref (se->expr);
640 /* Dereference non-character pointer variables.
641 These must be dummies, results, or scalars. */
642 if ((sym->attr.pointer || sym->attr.allocatable)
644 || sym->attr.function
646 || !sym->attr.dimension))
647 se->expr = build_fold_indirect_ref (se->expr);
653 /* For character variables, also get the length. */
654 if (sym->ts.type == BT_CHARACTER)
656 /* If the character length of an entry isn't set, get the length from
657 the master function instead. */
658 if (sym->attr.entry && !sym->ts.cl->backend_decl)
659 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
661 se->string_length = sym->ts.cl->backend_decl;
662 gcc_assert (se->string_length);
670 /* Return the descriptor if that's what we want and this is an array
671 section reference. */
672 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
674 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
675 /* Return the descriptor for array pointers and allocations. */
677 && ref->next == NULL && (se->descriptor_only))
680 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
681 /* Return a pointer to an element. */
685 if (ref->u.c.sym->attr.extension)
686 conv_parent_component_references (se, ref);
688 gfc_conv_component_ref (se, ref);
692 gfc_conv_substring (se, ref, expr->ts.kind,
693 expr->symtree->name, &expr->where);
702 /* Pointer assignment, allocation or pass by reference. Arrays are handled
704 if (se->want_pointer)
706 if (expr->ts.type == BT_CHARACTER)
707 gfc_conv_string_parameter (se);
709 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
714 /* Unary ops are easy... Or they would be if ! was a valid op. */
717 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
722 gcc_assert (expr->ts.type != BT_CHARACTER);
723 /* Initialize the operand. */
724 gfc_init_se (&operand, se);
725 gfc_conv_expr_val (&operand, expr->value.op.op1);
726 gfc_add_block_to_block (&se->pre, &operand.pre);
728 type = gfc_typenode_for_spec (&expr->ts);
730 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
731 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
732 All other unary operators have an equivalent GIMPLE unary operator. */
733 if (code == TRUTH_NOT_EXPR)
734 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
735 build_int_cst (type, 0));
737 se->expr = fold_build1 (code, type, operand.expr);
741 /* Expand power operator to optimal multiplications when a value is raised
742 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
743 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
744 Programming", 3rd Edition, 1998. */
746 /* This code is mostly duplicated from expand_powi in the backend.
747 We establish the "optimal power tree" lookup table with the defined size.
748 The items in the table are the exponents used to calculate the index
749 exponents. Any integer n less than the value can get an "addition chain",
750 with the first node being one. */
751 #define POWI_TABLE_SIZE 256
753 /* The table is from builtins.c. */
754 static const unsigned char powi_table[POWI_TABLE_SIZE] =
756 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
757 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
758 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
759 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
760 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
761 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
762 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
763 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
764 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
765 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
766 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
767 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
768 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
769 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
770 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
771 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
772 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
773 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
774 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
775 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
776 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
777 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
778 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
779 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
780 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
781 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
782 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
783 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
784 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
785 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
786 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
787 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
790 /* If n is larger than lookup table's max index, we use the "window
792 #define POWI_WINDOW_SIZE 3
794 /* Recursive function to expand the power operator. The temporary
795 values are put in tmpvar. The function returns tmpvar[1] ** n. */
797 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
804 if (n < POWI_TABLE_SIZE)
809 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
810 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
814 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
815 op0 = gfc_conv_powi (se, n - digit, tmpvar);
816 op1 = gfc_conv_powi (se, digit, tmpvar);
820 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
824 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
825 tmp = gfc_evaluate_now (tmp, &se->pre);
827 if (n < POWI_TABLE_SIZE)
834 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
835 return 1. Else return 0 and a call to runtime library functions
836 will have to be built. */
838 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
843 tree vartmp[POWI_TABLE_SIZE];
845 unsigned HOST_WIDE_INT n;
848 /* If exponent is too large, we won't expand it anyway, so don't bother
849 with large integer values. */
850 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
853 m = double_int_to_shwi (TREE_INT_CST (rhs));
854 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
855 of the asymmetric range of the integer type. */
856 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
858 type = TREE_TYPE (lhs);
859 sgn = tree_int_cst_sgn (rhs);
861 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
862 || optimize_size) && (m > 2 || m < -1))
868 se->expr = gfc_build_const (type, integer_one_node);
872 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
873 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
875 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
876 lhs, build_int_cst (TREE_TYPE (lhs), -1));
877 cond = fold_build2 (EQ_EXPR, boolean_type_node,
878 lhs, build_int_cst (TREE_TYPE (lhs), 1));
881 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
884 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
885 se->expr = fold_build3 (COND_EXPR, type,
886 tmp, build_int_cst (type, 1),
887 build_int_cst (type, 0));
891 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
892 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
893 build_int_cst (type, 0));
894 se->expr = fold_build3 (COND_EXPR, type,
895 cond, build_int_cst (type, 1), tmp);
899 memset (vartmp, 0, sizeof (vartmp));
903 tmp = gfc_build_const (type, integer_one_node);
904 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
907 se->expr = gfc_conv_powi (se, n, vartmp);
913 /* Power op (**). Constant integer exponent has special handling. */
916 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
918 tree gfc_int4_type_node;
925 gfc_init_se (&lse, se);
926 gfc_conv_expr_val (&lse, expr->value.op.op1);
927 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
928 gfc_add_block_to_block (&se->pre, &lse.pre);
930 gfc_init_se (&rse, se);
931 gfc_conv_expr_val (&rse, expr->value.op.op2);
932 gfc_add_block_to_block (&se->pre, &rse.pre);
934 if (expr->value.op.op2->ts.type == BT_INTEGER
935 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
936 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
939 gfc_int4_type_node = gfc_get_int_type (4);
941 kind = expr->value.op.op1->ts.kind;
942 switch (expr->value.op.op2->ts.type)
945 ikind = expr->value.op.op2->ts.kind;
950 rse.expr = convert (gfc_int4_type_node, rse.expr);
972 if (expr->value.op.op1->ts.type == BT_INTEGER)
973 lse.expr = convert (gfc_int4_type_node, lse.expr);
998 switch (expr->value.op.op1->ts.type)
1001 if (kind == 3) /* Case 16 was not handled properly above. */
1003 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1007 /* Use builtins for real ** int4. */
1013 fndecl = built_in_decls[BUILT_IN_POWIF];
1017 fndecl = built_in_decls[BUILT_IN_POWI];
1022 fndecl = built_in_decls[BUILT_IN_POWIL];
1030 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1034 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1046 fndecl = built_in_decls[BUILT_IN_POWF];
1049 fndecl = built_in_decls[BUILT_IN_POW];
1053 fndecl = built_in_decls[BUILT_IN_POWL];
1064 fndecl = built_in_decls[BUILT_IN_CPOWF];
1067 fndecl = built_in_decls[BUILT_IN_CPOW];
1071 fndecl = built_in_decls[BUILT_IN_CPOWL];
1083 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
1087 /* Generate code to allocate a string temporary. */
1090 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1095 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
1097 if (gfc_can_put_var_on_stack (len))
1099 /* Create a temporary variable to hold the result. */
1100 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1101 build_int_cst (gfc_charlen_type_node, 1));
1102 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1104 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1105 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1107 tmp = build_array_type (TREE_TYPE (type), tmp);
1109 var = gfc_create_var (tmp, "str");
1110 var = gfc_build_addr_expr (type, var);
1114 /* Allocate a temporary to hold the result. */
1115 var = gfc_create_var (type, "pstr");
1116 tmp = gfc_call_malloc (&se->pre, type,
1117 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1118 fold_convert (TREE_TYPE (len),
1119 TYPE_SIZE (type))));
1120 gfc_add_modify (&se->pre, var, tmp);
1122 /* Free the temporary afterwards. */
1123 tmp = gfc_call_free (convert (pvoid_type_node, var));
1124 gfc_add_expr_to_block (&se->post, tmp);
1131 /* Handle a string concatenation operation. A temporary will be allocated to
1135 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1138 tree len, type, var, tmp, fndecl;
1140 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1141 && expr->value.op.op2->ts.type == BT_CHARACTER);
1142 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1144 gfc_init_se (&lse, se);
1145 gfc_conv_expr (&lse, expr->value.op.op1);
1146 gfc_conv_string_parameter (&lse);
1147 gfc_init_se (&rse, se);
1148 gfc_conv_expr (&rse, expr->value.op.op2);
1149 gfc_conv_string_parameter (&rse);
1151 gfc_add_block_to_block (&se->pre, &lse.pre);
1152 gfc_add_block_to_block (&se->pre, &rse.pre);
1154 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1155 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1156 if (len == NULL_TREE)
1158 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1159 lse.string_length, rse.string_length);
1162 type = build_pointer_type (type);
1164 var = gfc_conv_string_tmp (se, type, len);
1166 /* Do the actual concatenation. */
1167 if (expr->ts.kind == 1)
1168 fndecl = gfor_fndecl_concat_string;
1169 else if (expr->ts.kind == 4)
1170 fndecl = gfor_fndecl_concat_string_char4;
1174 tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
1175 rse.string_length, rse.expr);
1176 gfc_add_expr_to_block (&se->pre, tmp);
1178 /* Add the cleanup for the operands. */
1179 gfc_add_block_to_block (&se->pre, &rse.post);
1180 gfc_add_block_to_block (&se->pre, &lse.post);
1183 se->string_length = len;
1186 /* Translates an op expression. Common (binary) cases are handled by this
1187 function, others are passed on. Recursion is used in either case.
1188 We use the fact that (op1.ts == op2.ts) (except for the power
1190 Operators need no special handling for scalarized expressions as long as
1191 they call gfc_conv_simple_val to get their operands.
1192 Character strings get special handling. */
1195 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1197 enum tree_code code;
1206 switch (expr->value.op.op)
1208 case INTRINSIC_PARENTHESES:
1209 if (expr->ts.type == BT_REAL
1210 || expr->ts.type == BT_COMPLEX)
1212 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1213 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1218 case INTRINSIC_UPLUS:
1219 gfc_conv_expr (se, expr->value.op.op1);
1222 case INTRINSIC_UMINUS:
1223 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1227 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1230 case INTRINSIC_PLUS:
1234 case INTRINSIC_MINUS:
1238 case INTRINSIC_TIMES:
1242 case INTRINSIC_DIVIDE:
1243 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1244 an integer, we must round towards zero, so we use a
1246 if (expr->ts.type == BT_INTEGER)
1247 code = TRUNC_DIV_EXPR;
1252 case INTRINSIC_POWER:
1253 gfc_conv_power_op (se, expr);
1256 case INTRINSIC_CONCAT:
1257 gfc_conv_concat_op (se, expr);
1261 code = TRUTH_ANDIF_EXPR;
1266 code = TRUTH_ORIF_EXPR;
1270 /* EQV and NEQV only work on logicals, but since we represent them
1271 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1273 case INTRINSIC_EQ_OS:
1281 case INTRINSIC_NE_OS:
1282 case INTRINSIC_NEQV:
1289 case INTRINSIC_GT_OS:
1296 case INTRINSIC_GE_OS:
1303 case INTRINSIC_LT_OS:
1310 case INTRINSIC_LE_OS:
1316 case INTRINSIC_USER:
1317 case INTRINSIC_ASSIGN:
1318 /* These should be converted into function calls by the frontend. */
1322 fatal_error ("Unknown intrinsic op");
1326 /* The only exception to this is **, which is handled separately anyway. */
1327 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1329 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1333 gfc_init_se (&lse, se);
1334 gfc_conv_expr (&lse, expr->value.op.op1);
1335 gfc_add_block_to_block (&se->pre, &lse.pre);
1338 gfc_init_se (&rse, se);
1339 gfc_conv_expr (&rse, expr->value.op.op2);
1340 gfc_add_block_to_block (&se->pre, &rse.pre);
1344 gfc_conv_string_parameter (&lse);
1345 gfc_conv_string_parameter (&rse);
1347 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1348 rse.string_length, rse.expr,
1349 expr->value.op.op1->ts.kind);
1350 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1351 gfc_add_block_to_block (&lse.post, &rse.post);
1354 type = gfc_typenode_for_spec (&expr->ts);
1358 /* The result of logical ops is always boolean_type_node. */
1359 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1360 se->expr = convert (type, tmp);
1363 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1365 /* Add the post blocks. */
1366 gfc_add_block_to_block (&se->post, &rse.post);
1367 gfc_add_block_to_block (&se->post, &lse.post);
1370 /* If a string's length is one, we convert it to a single character. */
1373 string_to_single_character (tree len, tree str, int kind)
1375 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1377 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1378 && TREE_INT_CST_HIGH (len) == 0)
1380 str = fold_convert (gfc_get_pchar_type (kind), str);
1381 return build_fold_indirect_ref (str);
1389 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1392 if (sym->backend_decl)
1394 /* This becomes the nominal_type in
1395 function.c:assign_parm_find_data_types. */
1396 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1397 /* This becomes the passed_type in
1398 function.c:assign_parm_find_data_types. C promotes char to
1399 integer for argument passing. */
1400 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1402 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1407 /* If we have a constant character expression, make it into an
1409 if ((*expr)->expr_type == EXPR_CONSTANT)
1414 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1415 if ((*expr)->ts.kind != gfc_c_int_kind)
1417 /* The expr needs to be compatible with a C int. If the
1418 conversion fails, then the 2 causes an ICE. */
1419 ts.type = BT_INTEGER;
1420 ts.kind = gfc_c_int_kind;
1421 gfc_convert_type (*expr, &ts, 2);
1424 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1426 if ((*expr)->ref == NULL)
1428 se->expr = string_to_single_character
1429 (build_int_cst (integer_type_node, 1),
1430 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1432 ((*expr)->symtree->n.sym)),
1437 gfc_conv_variable (se, *expr);
1438 se->expr = string_to_single_character
1439 (build_int_cst (integer_type_node, 1),
1440 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1449 /* Compare two strings. If they are all single characters, the result is the
1450 subtraction of them. Otherwise, we build a library call. */
1453 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1459 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1460 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1462 sc1 = string_to_single_character (len1, str1, kind);
1463 sc2 = string_to_single_character (len2, str2, kind);
1465 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1467 /* Deal with single character specially. */
1468 sc1 = fold_convert (integer_type_node, sc1);
1469 sc2 = fold_convert (integer_type_node, sc2);
1470 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1474 /* Build a call for the comparison. */
1478 fndecl = gfor_fndecl_compare_string;
1480 fndecl = gfor_fndecl_compare_string_char4;
1484 tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
1491 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1495 if (is_proc_ptr_comp (expr, NULL))
1496 tmp = gfc_get_proc_ptr_comp (se, expr);
1497 else if (sym->attr.dummy)
1499 tmp = gfc_get_symbol_decl (sym);
1500 if (sym->attr.proc_pointer)
1501 tmp = build_fold_indirect_ref (tmp);
1502 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1503 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1507 if (!sym->backend_decl)
1508 sym->backend_decl = gfc_get_extern_function_decl (sym);
1510 tmp = sym->backend_decl;
1512 if (sym->attr.cray_pointee)
1514 /* TODO - make the cray pointee a pointer to a procedure,
1515 assign the pointer to it and use it for the call. This
1517 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1518 gfc_get_symbol_decl (sym->cp_pointer));
1519 tmp = gfc_evaluate_now (tmp, &se->pre);
1522 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1524 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1525 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1532 /* Translate the call for an elemental subroutine call used in an operator
1533 assignment. This is a simplified version of gfc_conv_procedure_call. */
1536 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1543 /* Only elemental subroutines with two arguments. */
1544 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1545 gcc_assert (sym->formal->next->next == NULL);
1547 gfc_init_block (&block);
1549 gfc_add_block_to_block (&block, &lse->pre);
1550 gfc_add_block_to_block (&block, &rse->pre);
1552 /* Build the argument list for the call, including hidden string lengths. */
1553 args = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL_TREE, lse->expr));
1554 args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, rse->expr));
1555 if (lse->string_length != NULL_TREE)
1556 args = gfc_chainon_list (args, lse->string_length);
1557 if (rse->string_length != NULL_TREE)
1558 args = gfc_chainon_list (args, rse->string_length);
1560 /* Build the function call. */
1561 gfc_init_se (&se, NULL);
1562 conv_function_val (&se, sym, NULL);
1563 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1564 tmp = build_call_list (tmp, se.expr, args);
1565 gfc_add_expr_to_block (&block, tmp);
1567 gfc_add_block_to_block (&block, &lse->post);
1568 gfc_add_block_to_block (&block, &rse->post);
1570 return gfc_finish_block (&block);
1574 /* Initialize MAPPING. */
1577 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1579 mapping->syms = NULL;
1580 mapping->charlens = NULL;
1584 /* Free all memory held by MAPPING (but not MAPPING itself). */
1587 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1589 gfc_interface_sym_mapping *sym;
1590 gfc_interface_sym_mapping *nextsym;
1592 gfc_charlen *nextcl;
1594 for (sym = mapping->syms; sym; sym = nextsym)
1596 nextsym = sym->next;
1597 sym->new_sym->n.sym->formal = NULL;
1598 gfc_free_symbol (sym->new_sym->n.sym);
1599 gfc_free_expr (sym->expr);
1600 gfc_free (sym->new_sym);
1603 for (cl = mapping->charlens; cl; cl = nextcl)
1606 gfc_free_expr (cl->length);
1612 /* Return a copy of gfc_charlen CL. Add the returned structure to
1613 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1615 static gfc_charlen *
1616 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1619 gfc_charlen *new_charlen;
1621 new_charlen = gfc_get_charlen ();
1622 new_charlen->next = mapping->charlens;
1623 new_charlen->length = gfc_copy_expr (cl->length);
1625 mapping->charlens = new_charlen;
1630 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1631 array variable that can be used as the actual argument for dummy
1632 argument SYM. Add any initialization code to BLOCK. PACKED is as
1633 for gfc_get_nodesc_array_type and DATA points to the first element
1634 in the passed array. */
1637 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1638 gfc_packed packed, tree data)
1643 type = gfc_typenode_for_spec (&sym->ts);
1644 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1646 var = gfc_create_var (type, "ifm");
1647 gfc_add_modify (block, var, fold_convert (type, data));
1653 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1654 and offset of descriptorless array type TYPE given that it has the same
1655 size as DESC. Add any set-up code to BLOCK. */
1658 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1665 offset = gfc_index_zero_node;
1666 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1668 dim = gfc_rank_cst[n];
1669 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1670 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1672 GFC_TYPE_ARRAY_LBOUND (type, n)
1673 = gfc_conv_descriptor_lbound (desc, dim);
1674 GFC_TYPE_ARRAY_UBOUND (type, n)
1675 = gfc_conv_descriptor_ubound (desc, dim);
1677 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1679 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1680 gfc_conv_descriptor_ubound (desc, dim),
1681 gfc_conv_descriptor_lbound (desc, dim));
1682 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1683 GFC_TYPE_ARRAY_LBOUND (type, n),
1685 tmp = gfc_evaluate_now (tmp, block);
1686 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1688 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1689 GFC_TYPE_ARRAY_LBOUND (type, n),
1690 GFC_TYPE_ARRAY_STRIDE (type, n));
1691 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1693 offset = gfc_evaluate_now (offset, block);
1694 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1698 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1699 in SE. The caller may still use se->expr and se->string_length after
1700 calling this function. */
1703 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1704 gfc_symbol * sym, gfc_se * se,
1707 gfc_interface_sym_mapping *sm;
1711 gfc_symbol *new_sym;
1713 gfc_symtree *new_symtree;
1715 /* Create a new symbol to represent the actual argument. */
1716 new_sym = gfc_new_symbol (sym->name, NULL);
1717 new_sym->ts = sym->ts;
1718 new_sym->as = gfc_copy_array_spec (sym->as);
1719 new_sym->attr.referenced = 1;
1720 new_sym->attr.dimension = sym->attr.dimension;
1721 new_sym->attr.pointer = sym->attr.pointer;
1722 new_sym->attr.allocatable = sym->attr.allocatable;
1723 new_sym->attr.flavor = sym->attr.flavor;
1724 new_sym->attr.function = sym->attr.function;
1726 /* Ensure that the interface is available and that
1727 descriptors are passed for array actual arguments. */
1728 if (sym->attr.flavor == FL_PROCEDURE)
1730 new_sym->formal = expr->symtree->n.sym->formal;
1731 new_sym->attr.always_explicit
1732 = expr->symtree->n.sym->attr.always_explicit;
1735 /* Create a fake symtree for it. */
1737 new_symtree = gfc_new_symtree (&root, sym->name);
1738 new_symtree->n.sym = new_sym;
1739 gcc_assert (new_symtree == root);
1741 /* Create a dummy->actual mapping. */
1742 sm = XCNEW (gfc_interface_sym_mapping);
1743 sm->next = mapping->syms;
1745 sm->new_sym = new_symtree;
1746 sm->expr = gfc_copy_expr (expr);
1749 /* Stabilize the argument's value. */
1750 if (!sym->attr.function && se)
1751 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1753 if (sym->ts.type == BT_CHARACTER)
1755 /* Create a copy of the dummy argument's length. */
1756 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1757 sm->expr->ts.cl = new_sym->ts.cl;
1759 /* If the length is specified as "*", record the length that
1760 the caller is passing. We should use the callee's length
1761 in all other cases. */
1762 if (!new_sym->ts.cl->length && se)
1764 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1765 new_sym->ts.cl->backend_decl = se->string_length;
1772 /* Use the passed value as-is if the argument is a function. */
1773 if (sym->attr.flavor == FL_PROCEDURE)
1776 /* If the argument is either a string or a pointer to a string,
1777 convert it to a boundless character type. */
1778 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1780 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1781 tmp = build_pointer_type (tmp);
1782 if (sym->attr.pointer)
1783 value = build_fold_indirect_ref (se->expr);
1786 value = fold_convert (tmp, value);
1789 /* If the argument is a scalar, a pointer to an array or an allocatable,
1791 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1792 value = build_fold_indirect_ref (se->expr);
1794 /* For character(*), use the actual argument's descriptor. */
1795 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1796 value = build_fold_indirect_ref (se->expr);
1798 /* If the argument is an array descriptor, use it to determine
1799 information about the actual argument's shape. */
1800 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1801 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1803 /* Get the actual argument's descriptor. */
1804 desc = build_fold_indirect_ref (se->expr);
1806 /* Create the replacement variable. */
1807 tmp = gfc_conv_descriptor_data_get (desc);
1808 value = gfc_get_interface_mapping_array (&se->pre, sym,
1811 /* Use DESC to work out the upper bounds, strides and offset. */
1812 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1815 /* Otherwise we have a packed array. */
1816 value = gfc_get_interface_mapping_array (&se->pre, sym,
1817 PACKED_FULL, se->expr);
1819 new_sym->backend_decl = value;
1823 /* Called once all dummy argument mappings have been added to MAPPING,
1824 but before the mapping is used to evaluate expressions. Pre-evaluate
1825 the length of each argument, adding any initialization code to PRE and
1826 any finalization code to POST. */
1829 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1830 stmtblock_t * pre, stmtblock_t * post)
1832 gfc_interface_sym_mapping *sym;
1836 for (sym = mapping->syms; sym; sym = sym->next)
1837 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1838 && !sym->new_sym->n.sym->ts.cl->backend_decl)
1840 expr = sym->new_sym->n.sym->ts.cl->length;
1841 gfc_apply_interface_mapping_to_expr (mapping, expr);
1842 gfc_init_se (&se, NULL);
1843 gfc_conv_expr (&se, expr);
1844 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1845 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1846 gfc_add_block_to_block (pre, &se.pre);
1847 gfc_add_block_to_block (post, &se.post);
1849 sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
1854 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1858 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1859 gfc_constructor * c)
1861 for (; c; c = c->next)
1863 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1866 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1867 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1868 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1874 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1878 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1883 for (; ref; ref = ref->next)
1887 for (n = 0; n < ref->u.ar.dimen; n++)
1889 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1890 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1891 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1893 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1900 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1901 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1907 /* Convert intrinsic function calls into result expressions. */
1910 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1918 arg1 = expr->value.function.actual->expr;
1919 if (expr->value.function.actual->next)
1920 arg2 = expr->value.function.actual->next->expr;
1924 sym = arg1->symtree->n.sym;
1926 if (sym->attr.dummy)
1931 switch (expr->value.function.isym->id)
1934 /* TODO figure out why this condition is necessary. */
1935 if (sym->attr.function
1936 && (arg1->ts.cl->length == NULL
1937 || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
1938 && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
1941 new_expr = gfc_copy_expr (arg1->ts.cl->length);
1948 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1950 dup = mpz_get_si (arg2->value.integer);
1955 dup = sym->as->rank;
1959 for (; d < dup; d++)
1963 if (!sym->as->upper[d] || !sym->as->lower[d])
1965 gfc_free_expr (new_expr);
1969 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1970 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1972 new_expr = gfc_multiply (new_expr, tmp);
1978 case GFC_ISYM_LBOUND:
1979 case GFC_ISYM_UBOUND:
1980 /* TODO These implementations of lbound and ubound do not limit if
1981 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1986 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1987 d = mpz_get_si (arg2->value.integer) - 1;
1989 /* TODO: If the need arises, this could produce an array of
1993 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1995 if (sym->as->lower[d])
1996 new_expr = gfc_copy_expr (sym->as->lower[d]);
2000 if (sym->as->upper[d])
2001 new_expr = gfc_copy_expr (sym->as->upper[d]);
2009 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2013 gfc_replace_expr (expr, new_expr);
2019 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2020 gfc_interface_mapping * mapping)
2022 gfc_formal_arglist *f;
2023 gfc_actual_arglist *actual;
2025 actual = expr->value.function.actual;
2026 f = map_expr->symtree->n.sym->formal;
2028 for (; f && actual; f = f->next, actual = actual->next)
2033 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2036 if (map_expr->symtree->n.sym->attr.dimension)
2041 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2043 for (d = 0; d < as->rank; d++)
2045 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2046 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2049 expr->value.function.esym->as = as;
2052 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2054 expr->value.function.esym->ts.cl->length
2055 = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
2057 gfc_apply_interface_mapping_to_expr (mapping,
2058 expr->value.function.esym->ts.cl->length);
2063 /* EXPR is a copy of an expression that appeared in the interface
2064 associated with MAPPING. Walk it recursively looking for references to
2065 dummy arguments that MAPPING maps to actual arguments. Replace each such
2066 reference with a reference to the associated actual argument. */
2069 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2072 gfc_interface_sym_mapping *sym;
2073 gfc_actual_arglist *actual;
2078 /* Copying an expression does not copy its length, so do that here. */
2079 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
2081 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
2082 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
2085 /* Apply the mapping to any references. */
2086 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2088 /* ...and to the expression's symbol, if it has one. */
2089 /* TODO Find out why the condition on expr->symtree had to be moved into
2090 the loop rather than being outside it, as originally. */
2091 for (sym = mapping->syms; sym; sym = sym->next)
2092 if (expr->symtree && sym->old == expr->symtree->n.sym)
2094 if (sym->new_sym->n.sym->backend_decl)
2095 expr->symtree = sym->new_sym;
2097 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2100 /* ...and to subexpressions in expr->value. */
2101 switch (expr->expr_type)
2106 case EXPR_SUBSTRING:
2110 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2111 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2115 for (actual = expr->value.function.actual; actual; actual = actual->next)
2116 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2118 if (expr->value.function.esym == NULL
2119 && expr->value.function.isym != NULL
2120 && expr->value.function.actual->expr->symtree
2121 && gfc_map_intrinsic_function (expr, mapping))
2124 for (sym = mapping->syms; sym; sym = sym->next)
2125 if (sym->old == expr->value.function.esym)
2127 expr->value.function.esym = sym->new_sym->n.sym;
2128 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2129 expr->value.function.esym->result = sym->new_sym->n.sym;
2134 case EXPR_STRUCTURE:
2135 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2148 /* Evaluate interface expression EXPR using MAPPING. Store the result
2152 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2153 gfc_se * se, gfc_expr * expr)
2155 expr = gfc_copy_expr (expr);
2156 gfc_apply_interface_mapping_to_expr (mapping, expr);
2157 gfc_conv_expr (se, expr);
2158 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2159 gfc_free_expr (expr);
2163 /* Returns a reference to a temporary array into which a component of
2164 an actual argument derived type array is copied and then returned
2165 after the function call. */
2167 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2168 int g77, sym_intent intent)
2184 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2186 gfc_init_se (&lse, NULL);
2187 gfc_init_se (&rse, NULL);
2189 /* Walk the argument expression. */
2190 rss = gfc_walk_expr (expr);
2192 gcc_assert (rss != gfc_ss_terminator);
2194 /* Initialize the scalarizer. */
2195 gfc_init_loopinfo (&loop);
2196 gfc_add_ss_to_loop (&loop, rss);
2198 /* Calculate the bounds of the scalarization. */
2199 gfc_conv_ss_startstride (&loop);
2201 /* Build an ss for the temporary. */
2202 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2203 gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
2205 base_type = gfc_typenode_for_spec (&expr->ts);
2206 if (GFC_ARRAY_TYPE_P (base_type)
2207 || GFC_DESCRIPTOR_TYPE_P (base_type))
2208 base_type = gfc_get_element_type (base_type);
2210 loop.temp_ss = gfc_get_ss ();;
2211 loop.temp_ss->type = GFC_SS_TEMP;
2212 loop.temp_ss->data.temp.type = base_type;
2214 if (expr->ts.type == BT_CHARACTER)
2215 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2217 loop.temp_ss->string_length = NULL;
2219 parmse->string_length = loop.temp_ss->string_length;
2220 loop.temp_ss->data.temp.dimen = loop.dimen;
2221 loop.temp_ss->next = gfc_ss_terminator;
2223 /* Associate the SS with the loop. */
2224 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2226 /* Setup the scalarizing loops. */
2227 gfc_conv_loop_setup (&loop, &expr->where);
2229 /* Pass the temporary descriptor back to the caller. */
2230 info = &loop.temp_ss->data.info;
2231 parmse->expr = info->descriptor;
2233 /* Setup the gfc_se structures. */
2234 gfc_copy_loopinfo_to_se (&lse, &loop);
2235 gfc_copy_loopinfo_to_se (&rse, &loop);
2238 lse.ss = loop.temp_ss;
2239 gfc_mark_ss_chain_used (rss, 1);
2240 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2242 /* Start the scalarized loop body. */
2243 gfc_start_scalarized_body (&loop, &body);
2245 /* Translate the expression. */
2246 gfc_conv_expr (&rse, expr);
2248 gfc_conv_tmp_array_ref (&lse);
2249 gfc_advance_se_ss_chain (&lse);
2251 if (intent != INTENT_OUT)
2253 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2254 gfc_add_expr_to_block (&body, tmp);
2255 gcc_assert (rse.ss == gfc_ss_terminator);
2256 gfc_trans_scalarizing_loops (&loop, &body);
2260 /* Make sure that the temporary declaration survives by merging
2261 all the loop declarations into the current context. */
2262 for (n = 0; n < loop.dimen; n++)
2264 gfc_merge_block_scope (&body);
2265 body = loop.code[loop.order[n]];
2267 gfc_merge_block_scope (&body);
2270 /* Add the post block after the second loop, so that any
2271 freeing of allocated memory is done at the right time. */
2272 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2274 /**********Copy the temporary back again.*********/
2276 gfc_init_se (&lse, NULL);
2277 gfc_init_se (&rse, NULL);
2279 /* Walk the argument expression. */
2280 lss = gfc_walk_expr (expr);
2281 rse.ss = loop.temp_ss;
2284 /* Initialize the scalarizer. */
2285 gfc_init_loopinfo (&loop2);
2286 gfc_add_ss_to_loop (&loop2, lss);
2288 /* Calculate the bounds of the scalarization. */
2289 gfc_conv_ss_startstride (&loop2);
2291 /* Setup the scalarizing loops. */
2292 gfc_conv_loop_setup (&loop2, &expr->where);
2294 gfc_copy_loopinfo_to_se (&lse, &loop2);
2295 gfc_copy_loopinfo_to_se (&rse, &loop2);
2297 gfc_mark_ss_chain_used (lss, 1);
2298 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2300 /* Declare the variable to hold the temporary offset and start the
2301 scalarized loop body. */
2302 offset = gfc_create_var (gfc_array_index_type, NULL);
2303 gfc_start_scalarized_body (&loop2, &body);
2305 /* Build the offsets for the temporary from the loop variables. The
2306 temporary array has lbounds of zero and strides of one in all
2307 dimensions, so this is very simple. The offset is only computed
2308 outside the innermost loop, so the overall transfer could be
2309 optimized further. */
2310 info = &rse.ss->data.info;
2312 tmp_index = gfc_index_zero_node;
2313 for (n = info->dimen - 1; n > 0; n--)
2316 tmp = rse.loop->loopvar[n];
2317 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2318 tmp, rse.loop->from[n]);
2319 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2322 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2323 rse.loop->to[n-1], rse.loop->from[n-1]);
2324 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2325 tmp_str, gfc_index_one_node);
2327 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2331 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2332 tmp_index, rse.loop->from[0]);
2333 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2335 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2336 rse.loop->loopvar[0], offset);
2338 /* Now use the offset for the reference. */
2339 tmp = build_fold_indirect_ref (info->data);
2340 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2342 if (expr->ts.type == BT_CHARACTER)
2343 rse.string_length = expr->ts.cl->backend_decl;
2345 gfc_conv_expr (&lse, expr);
2347 gcc_assert (lse.ss == gfc_ss_terminator);
2349 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2350 gfc_add_expr_to_block (&body, tmp);
2352 /* Generate the copying loops. */
2353 gfc_trans_scalarizing_loops (&loop2, &body);
2355 /* Wrap the whole thing up by adding the second loop to the post-block
2356 and following it by the post-block of the first loop. In this way,
2357 if the temporary needs freeing, it is done after use! */
2358 if (intent != INTENT_IN)
2360 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2361 gfc_add_block_to_block (&parmse->post, &loop2.post);
2364 gfc_add_block_to_block (&parmse->post, &loop.post);
2366 gfc_cleanup_loop (&loop);
2367 gfc_cleanup_loop (&loop2);
2369 /* Pass the string length to the argument expression. */
2370 if (expr->ts.type == BT_CHARACTER)
2371 parmse->string_length = expr->ts.cl->backend_decl;
2373 /* We want either the address for the data or the address of the descriptor,
2374 depending on the mode of passing array arguments. */
2376 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2378 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2384 /* Generate the code for argument list functions. */
2387 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2389 /* Pass by value for g77 %VAL(arg), pass the address
2390 indirectly for %LOC, else by reference. Thus %REF
2391 is a "do-nothing" and %LOC is the same as an F95
2393 if (strncmp (name, "%VAL", 4) == 0)
2394 gfc_conv_expr (se, expr);
2395 else if (strncmp (name, "%LOC", 4) == 0)
2397 gfc_conv_expr_reference (se, expr);
2398 se->expr = gfc_build_addr_expr (NULL, se->expr);
2400 else if (strncmp (name, "%REF", 4) == 0)
2401 gfc_conv_expr_reference (se, expr);
2403 gfc_error ("Unknown argument list function at %L", &expr->where);
2407 /* Generate code for a procedure call. Note can return se->post != NULL.
2408 If se->direct_byref is set then se->expr contains the return parameter.
2409 Return nonzero, if the call has alternate specifiers.
2410 'expr' is only needed for procedure pointer components. */
2413 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2414 gfc_actual_arglist * arg, gfc_expr * expr,
2417 gfc_interface_mapping mapping;
2431 gfc_formal_arglist *formal;
2432 int has_alternate_specifier = 0;
2433 bool need_interface_mapping;
2440 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2442 arglist = NULL_TREE;
2443 retargs = NULL_TREE;
2444 stringargs = NULL_TREE;
2449 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2451 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2453 if (arg->expr->rank == 0)
2454 gfc_conv_expr_reference (se, arg->expr);
2458 /* This is really the actual arg because no formal arglist is
2459 created for C_LOC. */
2460 fsym = arg->expr->symtree->n.sym;
2462 /* We should want it to do g77 calling convention. */
2464 && !(fsym->attr.pointer || fsym->attr.allocatable)
2465 && fsym->as->type != AS_ASSUMED_SHAPE;
2466 f = f || !sym->attr.always_explicit;
2468 argss = gfc_walk_expr (arg->expr);
2469 gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
2472 /* TODO -- the following two lines shouldn't be necessary, but
2473 they're removed a bug is exposed later in the codepath.
2474 This is workaround was thus introduced, but will have to be
2475 removed; please see PR 35150 for details about the issue. */
2476 se->expr = convert (pvoid_type_node, se->expr);
2477 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2481 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2483 arg->expr->ts.type = sym->ts.derived->ts.type;
2484 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2485 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2486 gfc_conv_expr_reference (se, arg->expr);
2490 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2491 && arg->next->expr->rank == 0)
2492 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2494 /* Convert c_f_pointer if fptr is a scalar
2495 and convert c_f_procpointer. */
2499 gfc_init_se (&cptrse, NULL);
2500 gfc_conv_expr (&cptrse, arg->expr);
2501 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2502 gfc_add_block_to_block (&se->post, &cptrse.post);
2504 gfc_init_se (&fptrse, NULL);
2505 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2506 || is_proc_ptr_comp (arg->next->expr, NULL))
2507 fptrse.want_pointer = 1;
2509 gfc_conv_expr (&fptrse, arg->next->expr);
2510 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2511 gfc_add_block_to_block (&se->post, &fptrse.post);
2513 if (is_proc_ptr_comp (arg->next->expr, NULL))
2514 tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
2516 tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
2517 se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
2518 fold_convert (tmp, cptrse.expr));
2522 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2527 /* Build the addr_expr for the first argument. The argument is
2528 already an *address* so we don't need to set want_pointer in
2530 gfc_init_se (&arg1se, NULL);
2531 gfc_conv_expr (&arg1se, arg->expr);
2532 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2533 gfc_add_block_to_block (&se->post, &arg1se.post);
2535 /* See if we were given two arguments. */
2536 if (arg->next == NULL)
2537 /* Only given one arg so generate a null and do a
2538 not-equal comparison against the first arg. */
2539 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2540 fold_convert (TREE_TYPE (arg1se.expr),
2541 null_pointer_node));
2547 /* Given two arguments so build the arg2se from second arg. */
2548 gfc_init_se (&arg2se, NULL);
2549 gfc_conv_expr (&arg2se, arg->next->expr);
2550 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2551 gfc_add_block_to_block (&se->post, &arg2se.post);
2553 /* Generate test to compare that the two args are equal. */
2554 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2555 arg1se.expr, arg2se.expr);
2556 /* Generate test to ensure that the first arg is not null. */
2557 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2558 arg1se.expr, null_pointer_node);
2560 /* Finally, the generated test must check that both arg1 is not
2561 NULL and that it is equal to the second arg. */
2562 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2563 not_null_expr, eq_expr);
2572 if (!sym->attr.elemental)
2574 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2575 if (se->ss->useflags)
2577 gcc_assert (gfc_return_by_reference (sym)
2578 && sym->result->attr.dimension);
2579 gcc_assert (se->loop != NULL);
2581 /* Access the previously obtained result. */
2582 gfc_conv_tmp_array_ref (se);
2583 gfc_advance_se_ss_chain (se);
2587 info = &se->ss->data.info;
2592 gfc_init_block (&post);
2593 gfc_init_interface_mapping (&mapping);
2594 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2595 && sym->ts.cl->length
2596 && sym->ts.cl->length->expr_type
2598 || sym->attr.dimension);
2599 formal = sym->formal;
2600 /* Evaluate the arguments. */
2601 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2604 fsym = formal ? formal->sym : NULL;
2605 parm_kind = MISSING;
2609 if (se->ignore_optional)
2611 /* Some intrinsics have already been resolved to the correct
2615 else if (arg->label)
2617 has_alternate_specifier = 1;
2622 /* Pass a NULL pointer for an absent arg. */
2623 gfc_init_se (&parmse, NULL);
2624 parmse.expr = null_pointer_node;
2625 if (arg->missing_arg_type == BT_CHARACTER)
2626 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2629 else if (se->ss && se->ss->useflags)
2631 /* An elemental function inside a scalarized loop. */
2632 gfc_init_se (&parmse, se);
2633 gfc_conv_expr_reference (&parmse, e);
2634 parm_kind = ELEMENTAL;
2638 /* A scalar or transformational function. */
2639 gfc_init_se (&parmse, NULL);
2640 argss = gfc_walk_expr (e);
2642 if (argss == gfc_ss_terminator)
2644 if (e->expr_type == EXPR_VARIABLE
2645 && e->symtree->n.sym->attr.cray_pointee
2646 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2648 /* The Cray pointer needs to be converted to a pointer to
2649 a type given by the expression. */
2650 gfc_conv_expr (&parmse, e);
2651 type = build_pointer_type (TREE_TYPE (parmse.expr));
2652 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2653 parmse.expr = convert (type, tmp);
2655 else if (fsym && fsym->attr.value)
2657 if (fsym->ts.type == BT_CHARACTER
2658 && fsym->ts.is_c_interop
2659 && fsym->ns->proc_name != NULL
2660 && fsym->ns->proc_name->attr.is_bind_c)
2663 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2664 if (parmse.expr == NULL)
2665 gfc_conv_expr (&parmse, e);
2668 gfc_conv_expr (&parmse, e);
2670 else if (arg->name && arg->name[0] == '%')
2671 /* Argument list functions %VAL, %LOC and %REF are signalled
2672 through arg->name. */
2673 conv_arglist_function (&parmse, arg->expr, arg->name);
2674 else if ((e->expr_type == EXPR_FUNCTION)
2675 && e->symtree->n.sym->attr.pointer
2676 && fsym && fsym->attr.target)
2678 gfc_conv_expr (&parmse, e);
2679 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2683 gfc_conv_expr_reference (&parmse, e);
2684 if (fsym && e->expr_type != EXPR_NULL
2685 && ((fsym->attr.pointer
2686 && fsym->attr.flavor != FL_PROCEDURE)
2687 || fsym->attr.proc_pointer))
2689 /* Scalar pointer dummy args require an extra level of
2690 indirection. The null pointer already contains
2691 this level of indirection. */
2692 parm_kind = SCALAR_POINTER;
2693 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2699 /* If the procedure requires an explicit interface, the actual
2700 argument is passed according to the corresponding formal
2701 argument. If the corresponding formal argument is a POINTER,
2702 ALLOCATABLE or assumed shape, we do not use g77's calling
2703 convention, and pass the address of the array descriptor
2704 instead. Otherwise we use g77's calling convention. */
2707 && !(fsym->attr.pointer || fsym->attr.allocatable)
2708 && fsym->as->type != AS_ASSUMED_SHAPE;
2709 f = f || !sym->attr.always_explicit;
2711 if (e->expr_type == EXPR_VARIABLE
2712 && is_subref_array (e))
2713 /* The actual argument is a component reference to an
2714 array of derived types. In this case, the argument
2715 is converted to a temporary, which is passed and then
2716 written back after the procedure call. */
2717 gfc_conv_subref_array_arg (&parmse, e, f,
2718 fsym ? fsym->attr.intent : INTENT_INOUT);
2720 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2723 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2724 allocated on entry, it must be deallocated. */
2725 if (fsym && fsym->attr.allocatable
2726 && fsym->attr.intent == INTENT_OUT)
2728 tmp = build_fold_indirect_ref (parmse.expr);
2729 tmp = gfc_trans_dealloc_allocated (tmp);
2730 gfc_add_expr_to_block (&se->pre, tmp);
2736 /* The case with fsym->attr.optional is that of a user subroutine
2737 with an interface indicating an optional argument. When we call
2738 an intrinsic subroutine, however, fsym is NULL, but we might still
2739 have an optional argument, so we proceed to the substitution
2741 if (e && (fsym == NULL || fsym->attr.optional))
2743 /* If an optional argument is itself an optional dummy argument,
2744 check its presence and substitute a null if absent. */
2745 if (e->expr_type == EXPR_VARIABLE
2746 && e->symtree->n.sym->attr.optional)
2747 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2748 e->representation.length);
2753 /* Obtain the character length of an assumed character length
2754 length procedure from the typespec. */
2755 if (fsym->ts.type == BT_CHARACTER
2756 && parmse.string_length == NULL_TREE
2757 && e->ts.type == BT_PROCEDURE
2758 && e->symtree->n.sym->ts.type == BT_CHARACTER
2759 && e->symtree->n.sym->ts.cl->length != NULL
2760 && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
2762 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2763 parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2767 if (fsym && need_interface_mapping && e)
2768 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2770 gfc_add_block_to_block (&se->pre, &parmse.pre);
2771 gfc_add_block_to_block (&post, &parmse.post);
2773 /* Allocated allocatable components of derived types must be
2774 deallocated for non-variable scalars. Non-variable arrays are
2775 dealt with in trans-array.c(gfc_conv_array_parameter). */
2776 if (e && e->ts.type == BT_DERIVED
2777 && e->ts.derived->attr.alloc_comp
2778 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2781 tmp = build_fold_indirect_ref (parmse.expr);
2782 parm_rank = e->rank;
2790 case (SCALAR_POINTER):
2791 tmp = build_fold_indirect_ref (tmp);
2795 if (e->expr_type == EXPR_OP
2796 && e->value.op.op == INTRINSIC_PARENTHESES
2797 && e->value.op.op1->expr_type == EXPR_VARIABLE)
2800 local_tmp = gfc_evaluate_now (tmp, &se->pre);
2801 local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
2802 gfc_add_expr_to_block (&se->post, local_tmp);
2805 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2807 gfc_add_expr_to_block (&se->post, tmp);
2810 /* Character strings are passed as two parameters, a length and a
2811 pointer - except for Bind(c) which only passes the pointer. */
2812 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2813 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2815 arglist = gfc_chainon_list (arglist, parmse.expr);
2817 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2820 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2821 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2822 else if (ts.type == BT_CHARACTER)
2824 if (sym->ts.cl->length == NULL)
2826 /* Assumed character length results are not allowed by 5.1.1.5 of the
2827 standard and are trapped in resolve.c; except in the case of SPREAD
2828 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2829 we take the character length of the first argument for the result.
2830 For dummies, we have to look through the formal argument list for
2831 this function and use the character length found there.*/
2832 if (!sym->attr.dummy)
2833 cl.backend_decl = TREE_VALUE (stringargs);
2836 formal = sym->ns->proc_name->formal;
2837 for (; formal; formal = formal->next)
2838 if (strcmp (formal->sym->name, sym->name) == 0)
2839 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2846 /* Calculate the length of the returned string. */
2847 gfc_init_se (&parmse, NULL);
2848 if (need_interface_mapping)
2849 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2851 gfc_conv_expr (&parmse, sym->ts.cl->length);
2852 gfc_add_block_to_block (&se->pre, &parmse.pre);
2853 gfc_add_block_to_block (&se->post, &parmse.post);
2855 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2856 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2857 build_int_cst (gfc_charlen_type_node, 0));
2858 cl.backend_decl = tmp;
2861 /* Set up a charlen structure for it. */
2866 len = cl.backend_decl;
2869 byref = gfc_return_by_reference (sym);
2872 if (se->direct_byref)
2874 /* Sometimes, too much indirection can be applied; e.g. for
2875 function_result = array_valued_recursive_function. */
2876 if (TREE_TYPE (TREE_TYPE (se->expr))
2877 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2878 && GFC_DESCRIPTOR_TYPE_P
2879 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2880 se->expr = build_fold_indirect_ref (se->expr);
2882 retargs = gfc_chainon_list (retargs, se->expr);
2884 else if (sym->result->attr.dimension)
2886 gcc_assert (se->loop && info);
2888 /* Set the type of the array. */
2889 tmp = gfc_typenode_for_spec (&ts);
2890 info->dimen = se->loop->dimen;
2892 /* Evaluate the bounds of the result, if known. */
2893 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2895 /* Create a temporary to store the result. In case the function
2896 returns a pointer, the temporary will be a shallow copy and
2897 mustn't be deallocated. */
2898 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2899 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2900 NULL_TREE, false, !sym->attr.pointer,
2901 callee_alloc, &se->ss->expr->where);
2903 /* Pass the temporary as the first argument. */
2904 tmp = info->descriptor;
2905 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2906 retargs = gfc_chainon_list (retargs, tmp);
2908 else if (ts.type == BT_CHARACTER)
2910 /* Pass the string length. */
2911 type = gfc_get_character_type (ts.kind, ts.cl);
2912 type = build_pointer_type (type);
2914 /* Return an address to a char[0:len-1]* temporary for
2915 character pointers. */
2916 if (sym->attr.pointer || sym->attr.allocatable)
2918 var = gfc_create_var (type, "pstr");
2920 /* Provide an address expression for the function arguments. */
2921 var = gfc_build_addr_expr (NULL_TREE, var);
2924 var = gfc_conv_string_tmp (se, type, len);
2926 retargs = gfc_chainon_list (retargs, var);
2930 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2932 type = gfc_get_complex_type (ts.kind);
2933 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
2934 retargs = gfc_chainon_list (retargs, var);
2937 /* Add the string length to the argument list. */
2938 if (ts.type == BT_CHARACTER)
2939 retargs = gfc_chainon_list (retargs, len);
2941 gfc_free_interface_mapping (&mapping);
2943 /* Add the return arguments. */
2944 arglist = chainon (retargs, arglist);
2946 /* Add the hidden string length parameters to the arguments. */
2947 arglist = chainon (arglist, stringargs);
2949 /* We may want to append extra arguments here. This is used e.g. for
2950 calls to libgfortran_matmul_??, which need extra information. */
2951 if (append_args != NULL_TREE)
2952 arglist = chainon (arglist, append_args);
2954 /* Generate the actual call. */
2955 conv_function_val (se, sym, expr);
2957 /* If there are alternate return labels, function type should be
2958 integer. Can't modify the type in place though, since it can be shared
2959 with other functions. For dummy arguments, the typing is done to
2960 to this result, even if it has to be repeated for each call. */
2961 if (has_alternate_specifier
2962 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2964 if (!sym->attr.dummy)
2966 TREE_TYPE (sym->backend_decl)
2967 = build_function_type (integer_type_node,
2968 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2969 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
2972 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2975 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2976 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2978 /* If we have a pointer function, but we don't want a pointer, e.g.
2981 where f is pointer valued, we have to dereference the result. */
2982 if (!se->want_pointer && !byref && sym->attr.pointer
2983 && !is_proc_ptr_comp (expr, NULL))
2984 se->expr = build_fold_indirect_ref (se->expr);
2986 /* f2c calling conventions require a scalar default real function to
2987 return a double precision result. Convert this back to default
2988 real. We only care about the cases that can happen in Fortran 77.
2990 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2991 && sym->ts.kind == gfc_default_real_kind
2992 && !sym->attr.always_explicit)
2993 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2995 /* A pure function may still have side-effects - it may modify its
2997 TREE_SIDE_EFFECTS (se->expr) = 1;
2999 if (!sym->attr.pure)
3000 TREE_SIDE_EFFECTS (se->expr) = 1;
3005 /* Add the function call to the pre chain. There is no expression. */
3006 gfc_add_expr_to_block (&se->pre, se->expr);
3007 se->expr = NULL_TREE;
3009 if (!se->direct_byref)
3011 if (sym->attr.dimension)
3013 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3015 /* Check the data pointer hasn't been modified. This would
3016 happen in a function returning a pointer. */
3017 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3018 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3020 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3023 se->expr = info->descriptor;
3024 /* Bundle in the string length. */
3025 se->string_length = len;
3027 else if (sym->ts.type == BT_CHARACTER)
3029 /* Dereference for character pointer results. */
3030 if (sym->attr.pointer || sym->attr.allocatable)
3031 se->expr = build_fold_indirect_ref (var);
3035 se->string_length = len;
3039 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3040 se->expr = build_fold_indirect_ref (var);
3045 /* Follow the function call with the argument post block. */
3047 gfc_add_block_to_block (&se->pre, &post);
3049 gfc_add_block_to_block (&se->post, &post);
3051 return has_alternate_specifier;
3055 /* Fill a character string with spaces. */
3058 fill_with_spaces (tree start, tree type, tree size)
3060 stmtblock_t block, loop;
3061 tree i, el, exit_label, cond, tmp;
3063 /* For a simple char type, we can call memset(). */
3064 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3065 return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
3066 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3067 lang_hooks.to_target_charset (' ')),
3070 /* Otherwise, we use a loop:
3071 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3075 /* Initialize variables. */
3076 gfc_init_block (&block);
3077 i = gfc_create_var (sizetype, "i");
3078 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3079 el = gfc_create_var (build_pointer_type (type), "el");
3080 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3081 exit_label = gfc_build_label_decl (NULL_TREE);
3082 TREE_USED (exit_label) = 1;
3086 gfc_init_block (&loop);
3088 /* Exit condition. */
3089 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3090 fold_convert (sizetype, integer_zero_node));
3091 tmp = build1_v (GOTO_EXPR, exit_label);
3092 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3093 gfc_add_expr_to_block (&loop, tmp);
3096 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3097 build_int_cst (type,
3098 lang_hooks.to_target_charset (' ')));
3100 /* Increment loop variables. */
3101 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3102 TYPE_SIZE_UNIT (type)));
3103 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3105 TYPE_SIZE_UNIT (type)));
3107 /* Making the loop... actually loop! */
3108 tmp = gfc_finish_block (&loop);
3109 tmp = build1_v (LOOP_EXPR, tmp);
3110 gfc_add_expr_to_block (&block, tmp);
3112 /* The exit label. */
3113 tmp = build1_v (LABEL_EXPR, exit_label);
3114 gfc_add_expr_to_block (&block, tmp);
3117 return gfc_finish_block (&block);
3121 /* Generate code to copy a string. */
3124 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3125 int dkind, tree slength, tree src, int skind)
3127 tree tmp, dlen, slen;
3136 stmtblock_t tempblock;
3138 gcc_assert (dkind == skind);
3140 if (slength != NULL_TREE)
3142 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3143 ssc = string_to_single_character (slen, src, skind);
3147 slen = build_int_cst (size_type_node, 1);
3151 if (dlength != NULL_TREE)
3153 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3154 dsc = string_to_single_character (slen, dest, dkind);
3158 dlen = build_int_cst (size_type_node, 1);
3162 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3163 ssc = string_to_single_character (slen, src, skind);
3164 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3165 dsc = string_to_single_character (dlen, dest, dkind);
3168 /* Assign directly if the types are compatible. */
3169 if (dsc != NULL_TREE && ssc != NULL_TREE
3170 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3172 gfc_add_modify (block, dsc, ssc);
3176 /* Do nothing if the destination length is zero. */
3177 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3178 build_int_cst (size_type_node, 0));
3180 /* The following code was previously in _gfortran_copy_string:
3182 // The two strings may overlap so we use memmove.
3184 copy_string (GFC_INTEGER_4 destlen, char * dest,
3185 GFC_INTEGER_4 srclen, const char * src)
3187 if (srclen >= destlen)
3189 // This will truncate if too long.
3190 memmove (dest, src, destlen);
3194 memmove (dest, src, srclen);
3196 memset (&dest[srclen], ' ', destlen - srclen);
3200 We're now doing it here for better optimization, but the logic
3203 /* For non-default character kinds, we have to multiply the string
3204 length by the base type size. */
3205 chartype = gfc_get_char_type (dkind);
3206 slen = fold_build2 (MULT_EXPR, size_type_node,
3207 fold_convert (size_type_node, slen),
3208 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3209 dlen = fold_build2 (MULT_EXPR, size_type_node,
3210 fold_convert (size_type_node, dlen),
3211 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3214 dest = fold_convert (pvoid_type_node, dest);
3216 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3219 src = fold_convert (pvoid_type_node, src);
3221 src = gfc_build_addr_expr (pvoid_type_node, src);
3223 /* Truncate string if source is too long. */
3224 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3225 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3226 3, dest, src, dlen);
3228 /* Else copy and pad with spaces. */
3229 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3230 3, dest, src, slen);
3232 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3233 fold_convert (sizetype, slen));
3234 tmp4 = fill_with_spaces (tmp4, chartype,
3235 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3238 gfc_init_block (&tempblock);
3239 gfc_add_expr_to_block (&tempblock, tmp3);
3240 gfc_add_expr_to_block (&tempblock, tmp4);
3241 tmp3 = gfc_finish_block (&tempblock);
3243 /* The whole copy_string function is there. */
3244 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3245 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3246 gfc_add_expr_to_block (block, tmp);
3250 /* Translate a statement function.
3251 The value of a statement function reference is obtained by evaluating the
3252 expression using the values of the actual arguments for the values of the
3253 corresponding dummy arguments. */
3256 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3260 gfc_formal_arglist *fargs;
3261 gfc_actual_arglist *args;
3264 gfc_saved_var *saved_vars;
3270 sym = expr->symtree->n.sym;
3271 args = expr->value.function.actual;
3272 gfc_init_se (&lse, NULL);
3273 gfc_init_se (&rse, NULL);
3276 for (fargs = sym->formal; fargs; fargs = fargs->next)
3278 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3279 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3281 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3283 /* Each dummy shall be specified, explicitly or implicitly, to be
3285 gcc_assert (fargs->sym->attr.dimension == 0);
3288 /* Create a temporary to hold the value. */
3289 type = gfc_typenode_for_spec (&fsym->ts);
3290 temp_vars[n] = gfc_create_var (type, fsym->name);
3292 if (fsym->ts.type == BT_CHARACTER)
3294 /* Copy string arguments. */
3297 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3298 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3300 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3301 tmp = gfc_build_addr_expr (build_pointer_type (type),
3304 gfc_conv_expr (&rse, args->expr);
3305 gfc_conv_string_parameter (&rse);
3306 gfc_add_block_to_block (&se->pre, &lse.pre);
3307 gfc_add_block_to_block (&se->pre, &rse.pre);
3309 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3310 rse.string_length, rse.expr, fsym->ts.kind);
3311 gfc_add_block_to_block (&se->pre, &lse.post);
3312 gfc_add_block_to_block (&se->pre, &rse.post);
3316 /* For everything else, just evaluate the expression. */
3317 gfc_conv_expr (&lse, args->expr);
3319 gfc_add_block_to_block (&se->pre, &lse.pre);
3320 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3321 gfc_add_block_to_block (&se->pre, &lse.post);
3327 /* Use the temporary variables in place of the real ones. */
3328 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3329 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3331 gfc_conv_expr (se, sym->value);
3333 if (sym->ts.type == BT_CHARACTER)
3335 gfc_conv_const_charlen (sym->ts.cl);
3337 /* Force the expression to the correct length. */
3338 if (!INTEGER_CST_P (se->string_length)
3339 || tree_int_cst_lt (se->string_length,
3340 sym->ts.cl->backend_decl))
3342 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3343 tmp = gfc_create_var (type, sym->name);
3344 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3345 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3346 sym->ts.kind, se->string_length, se->expr,
3350 se->string_length = sym->ts.cl->backend_decl;
3353 /* Restore the original variables. */
3354 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3355 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3356 gfc_free (saved_vars);
3360 /* Return the backend_decl for a procedure pointer component. */
3363 gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
3366 gfc_init_se (&comp_se, NULL);
3367 e->expr_type = EXPR_VARIABLE;
3368 gfc_conv_expr (&comp_se, e);
3369 comp_se.expr = build_fold_addr_expr (comp_se.expr);
3370 return gfc_evaluate_now (comp_se.expr, &se->pre);
3374 /* Translate a function expression. */
3377 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3381 if (expr->value.function.isym)
3383 gfc_conv_intrinsic_function (se, expr);
3387 /* We distinguish statement functions from general functions to improve
3388 runtime performance. */
3389 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3391 gfc_conv_statement_function (se, expr);
3395 /* expr.value.function.esym is the resolved (specific) function symbol for
3396 most functions. However this isn't set for dummy procedures. */
3397 sym = expr->value.function.esym;
3399 sym = expr->symtree->n.sym;
3401 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3407 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3409 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3410 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3412 gfc_conv_tmp_array_ref (se);
3413 gfc_advance_se_ss_chain (se);
3417 /* Build a static initializer. EXPR is the expression for the initial value.
3418 The other parameters describe the variable of the component being
3419 initialized. EXPR may be null. */
3422 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3423 bool array, bool pointer)
3427 if (!(expr || pointer))
3430 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3431 (these are the only two iso_c_binding derived types that can be
3432 used as initialization expressions). If so, we need to modify
3433 the 'expr' to be that for a (void *). */
3434 if (expr != NULL && expr->ts.type == BT_DERIVED
3435 && expr->ts.is_iso_c && expr->ts.derived)
3437 gfc_symbol *derived = expr->ts.derived;
3439 expr = gfc_int_expr (0);
3441 /* The derived symbol has already been converted to a (void *). Use
3443 expr->ts.f90_type = derived->ts.f90_type;
3444 expr->ts.kind = derived->ts.kind;
3449 /* Arrays need special handling. */
3451 return gfc_build_null_descriptor (type);
3453 return gfc_conv_array_initializer (type, expr);
3456 return fold_convert (type, null_pointer_node);
3462 gfc_init_se (&se, NULL);
3463 gfc_conv_structure (&se, expr, 1);
3467 return gfc_conv_string_init (ts->cl->backend_decl,expr);
3470 gfc_init_se (&se, NULL);
3471 gfc_conv_constant (&se, expr);
3478 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3490 gfc_start_block (&block);
3492 /* Initialize the scalarizer. */
3493 gfc_init_loopinfo (&loop);
3495 gfc_init_se (&lse, NULL);
3496 gfc_init_se (&rse, NULL);
3499 rss = gfc_walk_expr (expr);
3500 if (rss == gfc_ss_terminator)
3502 /* The rhs is scalar. Add a ss for the expression. */
3503 rss = gfc_get_ss ();
3504 rss->next = gfc_ss_terminator;
3505 rss->type = GFC_SS_SCALAR;
3509 /* Create a SS for the destination. */
3510 lss = gfc_get_ss ();
3511 lss->type = GFC_SS_COMPONENT;
3513 lss->shape = gfc_get_shape (cm->as->rank);
3514 lss->next = gfc_ss_terminator;
3515 lss->data.info.dimen = cm->as->rank;
3516 lss->data.info.descriptor = dest;
3517 lss->data.info.data = gfc_conv_array_data (dest);
3518 lss->data.info.offset = gfc_conv_array_offset (dest);
3519 for (n = 0; n < cm->as->rank; n++)
3521 lss->data.info.dim[n] = n;
3522 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3523 lss->data.info.stride[n] = gfc_index_one_node;
3525 mpz_init (lss->shape[n]);
3526 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3527 cm->as->lower[n]->value.integer);
3528 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3531 /* Associate the SS with the loop. */
3532 gfc_add_ss_to_loop (&loop, lss);
3533 gfc_add_ss_to_loop (&loop, rss);
3535 /* Calculate the bounds of the scalarization. */
3536 gfc_conv_ss_startstride (&loop);
3538 /* Setup the scalarizing loops. */
3539 gfc_conv_loop_setup (&loop, &expr->where);
3541 /* Setup the gfc_se structures. */
3542 gfc_copy_loopinfo_to_se (&lse, &loop);
3543 gfc_copy_loopinfo_to_se (&rse, &loop);
3546 gfc_mark_ss_chain_used (rss, 1);
3548 gfc_mark_ss_chain_used (lss, 1);
3550 /* Start the scalarized loop body. */
3551 gfc_start_scalarized_body (&loop, &body);
3553 gfc_conv_tmp_array_ref (&lse);
3554 if (cm->ts.type == BT_CHARACTER)
3555 lse.string_length = cm->ts.cl->backend_decl;
3557 gfc_conv_expr (&rse, expr);
3559 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3560 gfc_add_expr_to_block (&body, tmp);
3562 gcc_assert (rse.ss == gfc_ss_terminator);
3564 /* Generate the copying loops. */
3565 gfc_trans_scalarizing_loops (&loop, &body);
3567 /* Wrap the whole thing up. */
3568 gfc_add_block_to_block (&block, &loop.pre);
3569 gfc_add_block_to_block (&block, &loop.post);
3571 for (n = 0; n < cm->as->rank; n++)
3572 mpz_clear (lss->shape[n]);
3573 gfc_free (lss->shape);
3575 gfc_cleanup_loop (&loop);
3577 return gfc_finish_block (&block);
3581 /* Assign a single component of a derived type constructor. */
3584 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3594 gfc_start_block (&block);
3596 if (cm->attr.pointer)
3598 gfc_init_se (&se, NULL);
3599 /* Pointer component. */
3600 if (cm->attr.dimension)
3602 /* Array pointer. */
3603 if (expr->expr_type == EXPR_NULL)
3604 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3607 rss = gfc_walk_expr (expr);
3608 se.direct_byref = 1;
3610 gfc_conv_expr_descriptor (&se, expr, rss);
3611 gfc_add_block_to_block (&block, &se.pre);
3612 gfc_add_block_to_block (&block, &se.post);
3617 /* Scalar pointers. */
3618 se.want_pointer = 1;
3619 gfc_conv_expr (&se, expr);
3620 gfc_add_block_to_block (&block, &se.pre);
3621 gfc_add_modify (&block, dest,
3622 fold_convert (TREE_TYPE (dest), se.expr));
3623 gfc_add_block_to_block (&block, &se.post);
3626 else if (cm->attr.dimension)
3628 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3629 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3630 else if (cm->attr.allocatable)
3634 gfc_init_se (&se, NULL);
3636 rss = gfc_walk_expr (expr);
3637 se.want_pointer = 0;
3638 gfc_conv_expr_descriptor (&se, expr, rss);
3639 gfc_add_block_to_block (&block, &se.pre);
3641 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3642 gfc_add_modify (&block, dest, tmp);
3644 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3645 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3648 tmp = gfc_duplicate_allocatable (dest, se.expr,
3649 TREE_TYPE(cm->backend_decl),
3652 gfc_add_expr_to_block (&block, tmp);
3653 gfc_add_block_to_block (&block, &se.post);
3655 if (expr->expr_type != EXPR_VARIABLE)
3656 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3658 /* Shift the lbound and ubound of temporaries to being unity, rather
3659 than zero, based. Calculate the offset for all cases. */
3660 offset = gfc_conv_descriptor_offset (dest);
3661 gfc_add_modify (&block, offset, gfc_index_zero_node);
3662 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3663 for (n = 0; n < expr->rank; n++)
3665 if (expr->expr_type != EXPR_VARIABLE
3666 && expr->expr_type != EXPR_CONSTANT)
3669 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3670 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3671 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3672 gfc_add_modify (&block, tmp,
3673 fold_build2 (PLUS_EXPR,
3674 gfc_array_index_type,
3675 span, gfc_index_one_node));
3676 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3677 gfc_add_modify (&block, tmp, gfc_index_one_node);
3679 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3680 gfc_conv_descriptor_lbound (dest,
3682 gfc_conv_descriptor_stride (dest,
3684 gfc_add_modify (&block, tmp2, tmp);
3685 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3686 gfc_add_modify (&block, offset, tmp);
3689 if (expr->expr_type == EXPR_FUNCTION
3690 && expr->value.function.isym
3691 && expr->value.function.isym->conversion
3692 && expr->value.function.actual->expr
3693 && expr->value.function.actual->expr->expr_type
3696 /* If a conversion expression has a null data pointer
3697 argument, nullify the allocatable component. */
3701 s = expr->value.function.actual->expr->symtree->n.sym;
3702 if (s->attr.allocatable || s->attr.pointer)
3704 non_null_expr = gfc_finish_block (&block);
3705 gfc_start_block (&block);
3706 gfc_conv_descriptor_data_set (&block, dest,
3708 null_expr = gfc_finish_block (&block);
3709 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
3710 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
3711 fold_convert (TREE_TYPE (tmp),
3712 null_pointer_node));
3713 return build3_v (COND_EXPR, tmp, null_expr,
3720 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3721 gfc_add_expr_to_block (&block, tmp);
3724 else if (expr->ts.type == BT_DERIVED)
3726 if (expr->expr_type != EXPR_STRUCTURE)
3728 gfc_init_se (&se, NULL);
3729 gfc_conv_expr (&se, expr);
3730 gfc_add_block_to_block (&block, &se.pre);
3731 gfc_add_modify (&block, dest,
3732 fold_convert (TREE_TYPE (dest), se.expr));
3733 gfc_add_block_to_block (&block, &se.post);
3737 /* Nested constructors. */
3738 tmp = gfc_trans_structure_assign (dest, expr);
3739 gfc_add_expr_to_block (&block, tmp);
3744 /* Scalar component. */
3745 gfc_init_se (&se, NULL);
3746 gfc_init_se (&lse, NULL);
3748 gfc_conv_expr (&se, expr);
3749 if (cm->ts.type == BT_CHARACTER)
3750 lse.string_length = cm->ts.cl->backend_decl;
3752 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3753 gfc_add_expr_to_block (&block, tmp);
3755 return gfc_finish_block (&block);
3758 /* Assign a derived type constructor to a variable. */
3761 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3769 gfc_start_block (&block);
3770 cm = expr->ts.derived->components;
3771 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3773 /* Skip absent members in default initializers. */
3777 field = cm->backend_decl;
3778 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3779 dest, field, NULL_TREE);
3780 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3781 gfc_add_expr_to_block (&block, tmp);
3783 return gfc_finish_block (&block);
3786 /* Build an expression for a constructor. If init is nonzero then
3787 this is part of a static variable initializer. */
3790 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3797 VEC(constructor_elt,gc) *v = NULL;
3799 gcc_assert (se->ss == NULL);
3800 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3801 type = gfc_typenode_for_spec (&expr->ts);
3805 /* Create a temporary variable and fill it in. */
3806 se->expr = gfc_create_var (type, expr->ts.derived->name);
3807 tmp = gfc_trans_structure_assign (se->expr, expr);
3808 gfc_add_expr_to_block (&se->pre, tmp);
3812 cm = expr->ts.derived->components;
3814 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3816 /* Skip absent members in default initializers and allocatable
3817 components. Although the latter have a default initializer
3818 of EXPR_NULL,... by default, the static nullify is not needed
3819 since this is done every time we come into scope. */
3820 if (!c->expr || cm->attr.allocatable)
3823 val = gfc_conv_initializer (c->expr, &cm->ts,
3824 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
3825 cm->attr.pointer || cm->attr.proc_pointer);
3827 /* Append it to the constructor list. */
3828 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3830 se->expr = build_constructor (type, v);
3832 TREE_CONSTANT (se->expr) = 1;
3836 /* Translate a substring expression. */
3839 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3845 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3847 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3848 expr->value.character.length,
3849 expr->value.character.string);
3851 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3852 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3855 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3859 /* Entry point for expression translation. Evaluates a scalar quantity.
3860 EXPR is the expression to be translated, and SE is the state structure if
3861 called from within the scalarized. */
3864 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3866 if (se->ss && se->ss->expr == expr
3867 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3869 /* Substitute a scalar expression evaluated outside the scalarization
3871 se->expr = se->ss->data.scalar.expr;
3872 se->string_length = se->ss->string_length;
3873 gfc_advance_se_ss_chain (se);
3877 /* We need to convert the expressions for the iso_c_binding derived types.
3878 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3879 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3880 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3881 updated to be an integer with a kind equal to the size of a (void *). */
3882 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3883 && expr->ts.derived->attr.is_iso_c)
3885 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3886 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3888 /* Set expr_type to EXPR_NULL, which will result in
3889 null_pointer_node being used below. */
3890 expr->expr_type = EXPR_NULL;
3894 /* Update the type/kind of the expression to be what the new
3895 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3896 expr->ts.type = expr->ts.derived->ts.type;
3897 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3898 expr->ts.kind = expr->ts.derived->ts.kind;
3902 switch (expr->expr_type)
3905 gfc_conv_expr_op (se, expr);
3909 gfc_conv_function_expr (se, expr);
3913 gfc_conv_constant (se, expr);
3917 gfc_conv_variable (se, expr);
3921 se->expr = null_pointer_node;
3924 case EXPR_SUBSTRING:
3925 gfc_conv_substring_expr (se, expr);
3928 case EXPR_STRUCTURE:
3929 gfc_conv_structure (se, expr, 0);
3933 gfc_conv_array_constructor_expr (se, expr);
3942 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3943 of an assignment. */
3945 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3947 gfc_conv_expr (se, expr);
3948 /* All numeric lvalues should have empty post chains. If not we need to
3949 figure out a way of rewriting an lvalue so that it has no post chain. */
3950 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3953 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3954 numeric expressions. Used for scalar values where inserting cleanup code
3957 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3961 gcc_assert (expr->ts.type != BT_CHARACTER);
3962 gfc_conv_expr (se, expr);
3965 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3966 gfc_add_modify (&se->pre, val, se->expr);
3968 gfc_add_block_to_block (&se->pre, &se->post);
3972 /* Helper to translate an expression and convert it to a particular type. */
3974 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3976 gfc_conv_expr_val (se, expr);
3977 se->expr = convert (type, se->expr);
3981 /* Converts an expression so that it can be passed by reference. Scalar
3985 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3989 if (se->ss && se->ss->expr == expr
3990 && se->ss->type == GFC_SS_REFERENCE)
3992 se->expr = se->ss->data.scalar.expr;
3993 se->string_length = se->ss->string_length;
3994 gfc_advance_se_ss_chain (se);
3998 if (expr->ts.type == BT_CHARACTER)
4000 gfc_conv_expr (se, expr);
4001 gfc_conv_string_parameter (se);
4005 if (expr->expr_type == EXPR_VARIABLE)
4007 se->want_pointer = 1;
4008 gfc_conv_expr (se, expr);
4011 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4012 gfc_add_modify (&se->pre, var, se->expr);
4013 gfc_add_block_to_block (&se->pre, &se->post);
4019 if (expr->expr_type == EXPR_FUNCTION
4020 && expr->symtree->n.sym->attr.pointer
4021 && !expr->symtree->n.sym->attr.dimension)
4023 se->want_pointer = 1;
4024 gfc_conv_expr (se, expr);
4025 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4026 gfc_add_modify (&se->pre, var, se->expr);
4032 gfc_conv_expr (se, expr);
4034 /* Create a temporary var to hold the value. */
4035 if (TREE_CONSTANT (se->expr))
4037 tree tmp = se->expr;
4038 STRIP_TYPE_NOPS (tmp);
4039 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
4040 DECL_INITIAL (var) = tmp;
4041 TREE_STATIC (var) = 1;
4046 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4047 gfc_add_modify (&se->pre, var, se->expr);
4049 gfc_add_block_to_block (&se->pre, &se->post);
4051 /* Take the address of that value. */
4052 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4057 gfc_trans_pointer_assign (gfc_code * code)
4059 return gfc_trans_pointer_assignment (code->expr, code->expr2);
4063 /* Generate code for a pointer assignment. */
4066 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4077 gfc_start_block (&block);
4079 gfc_init_se (&lse, NULL);
4081 lss = gfc_walk_expr (expr1);
4082 rss = gfc_walk_expr (expr2);
4083 if (lss == gfc_ss_terminator)
4085 /* Scalar pointers. */
4086 lse.want_pointer = 1;
4087 gfc_conv_expr (&lse, expr1);
4088 gcc_assert (rss == gfc_ss_terminator);
4089 gfc_init_se (&rse, NULL);
4090 rse.want_pointer = 1;
4091 gfc_conv_expr (&rse, expr2);
4093 if (expr1->symtree->n.sym->attr.proc_pointer
4094 && expr1->symtree->n.sym->attr.dummy)
4095 lse.expr = build_fold_indirect_ref (lse.expr);
4097 gfc_add_block_to_block (&block, &lse.pre);
4098 gfc_add_block_to_block (&block, &rse.pre);
4100 /* Check character lengths if character expression. The test is only
4101 really added if -fbounds-check is enabled. */
4102 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4104 gcc_assert (expr2->ts.type == BT_CHARACTER);
4105 gcc_assert (lse.string_length && rse.string_length);
4106 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4107 lse.string_length, rse.string_length,
4111 gfc_add_modify (&block, lse.expr,
4112 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4114 gfc_add_block_to_block (&block, &rse.post);
4115 gfc_add_block_to_block (&block, &lse.post);
4120 tree strlen_rhs = NULL_TREE;
4122 /* Array pointer. */
4123 gfc_conv_expr_descriptor (&lse, expr1, lss);
4124 strlen_lhs = lse.string_length;
4125 switch (expr2->expr_type)
4128 /* Just set the data pointer to null. */
4129 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4133 /* Assign directly to the pointer's descriptor. */
4134 lse.direct_byref = 1;
4135 gfc_conv_expr_descriptor (&lse, expr2, rss);
4136 strlen_rhs = lse.string_length;
4138 /* If this is a subreference array pointer assignment, use the rhs
4139 descriptor element size for the lhs span. */
4140 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4142 decl = expr1->symtree->n.sym->backend_decl;
4143 gfc_init_se (&rse, NULL);
4144 rse.descriptor_only = 1;
4145 gfc_conv_expr (&rse, expr2);
4146 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4147 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4148 if (!INTEGER_CST_P (tmp))
4149 gfc_add_block_to_block (&lse.post, &rse.pre);
4150 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4156 /* Assign to a temporary descriptor and then copy that
4157 temporary to the pointer. */
4159 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4162 lse.direct_byref = 1;
4163 gfc_conv_expr_descriptor (&lse, expr2, rss);
4164 strlen_rhs = lse.string_length;
4165 gfc_add_modify (&lse.pre, desc, tmp);
4169 gfc_add_block_to_block (&block, &lse.pre);
4171 /* Check string lengths if applicable. The check is only really added
4172 to the output code if -fbounds-check is enabled. */
4173 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4175 gcc_assert (expr2->ts.type == BT_CHARACTER);
4176 gcc_assert (strlen_lhs && strlen_rhs);
4177 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4178 strlen_lhs, strlen_rhs, &block);
4181 gfc_add_block_to_block (&block, &lse.post);
4183 return gfc_finish_block (&block);
4187 /* Makes sure se is suitable for passing as a function string parameter. */
4188 /* TODO: Need to check all callers of this function. It may be abused. */
4191 gfc_conv_string_parameter (gfc_se * se)
4195 if (TREE_CODE (se->expr) == STRING_CST)
4197 type = TREE_TYPE (TREE_TYPE (se->expr));
4198 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4202 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4204 if (TREE_CODE (se->expr) != INDIRECT_REF)
4206 type = TREE_TYPE (se->expr);
4207 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4211 type = gfc_get_character_type_len (gfc_default_character_kind,
4213 type = build_pointer_type (type);
4214 se->expr = gfc_build_addr_expr (type, se->expr);
4218 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4219 gcc_assert (se->string_length
4220 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4224 /* Generate code for assignment of scalar variables. Includes character
4225 strings and derived types with allocatable components. */
4228 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4229 bool l_is_temp, bool r_is_var)
4235 gfc_init_block (&block);
4237 if (ts.type == BT_CHARACTER)
4242 if (lse->string_length != NULL_TREE)
4244 gfc_conv_string_parameter (lse);
4245 gfc_add_block_to_block (&block, &lse->pre);
4246 llen = lse->string_length;
4249 if (rse->string_length != NULL_TREE)
4251 gcc_assert (rse->string_length != NULL_TREE);
4252 gfc_conv_string_parameter (rse);
4253 gfc_add_block_to_block (&block, &rse->pre);
4254 rlen = rse->string_length;
4257 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4258 rse->expr, ts.kind);
4260 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4264 /* Are the rhs and the lhs the same? */
4267 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4268 gfc_build_addr_expr (NULL_TREE, lse->expr),
4269 gfc_build_addr_expr (NULL_TREE, rse->expr));
4270 cond = gfc_evaluate_now (cond, &lse->pre);
4273 /* Deallocate the lhs allocated components as long as it is not
4274 the same as the rhs. This must be done following the assignment
4275 to prevent deallocating data that could be used in the rhs
4279 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4280 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4282 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4283 gfc_add_expr_to_block (&lse->post, tmp);
4286 gfc_add_block_to_block (&block, &rse->pre);
4287 gfc_add_block_to_block (&block, &lse->pre);
4289 gfc_add_modify (&block, lse->expr,
4290 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4292 /* Do a deep copy if the rhs is a variable, if it is not the
4296 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4297 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4298 gfc_add_expr_to_block (&block, tmp);
4303 gfc_add_block_to_block (&block, &lse->pre);
4304 gfc_add_block_to_block (&block, &rse->pre);
4306 gfc_add_modify (&block, lse->expr,
4307 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4310 gfc_add_block_to_block (&block, &lse->post);
4311 gfc_add_block_to_block (&block, &rse->post);
4313 return gfc_finish_block (&block);
4317 /* Try to translate array(:) = func (...), where func is a transformational
4318 array function, without using a temporary. Returns NULL is this isn't the
4322 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4327 bool seen_array_ref;
4329 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4330 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4333 /* Elemental functions don't need a temporary anyway. */
4334 if (expr2->value.function.esym != NULL
4335 && expr2->value.function.esym->attr.elemental)
4338 /* Fail if EXPR1 can't be expressed as a descriptor. */
4339 if (gfc_ref_needs_temporary_p (expr1->ref))
4342 /* Functions returning pointers need temporaries. */
4343 if (expr2->symtree->n.sym->attr.pointer
4344 || expr2->symtree->n.sym->attr.allocatable)
4347 /* Character array functions need temporaries unless the
4348 character lengths are the same. */
4349 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4351 if (expr1->ts.cl->length == NULL
4352 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4355 if (expr2->ts.cl->length == NULL
4356 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4359 if (mpz_cmp (expr1->ts.cl->length->value.integer,
4360 expr2->ts.cl->length->value.integer) != 0)
4364 /* Check that no LHS component references appear during an array
4365 reference. This is needed because we do not have the means to
4366 span any arbitrary stride with an array descriptor. This check
4367 is not needed for the rhs because the function result has to be
4369 seen_array_ref = false;
4370 for (ref = expr1->ref; ref; ref = ref->next)
4372 if (ref->type == REF_ARRAY)
4373 seen_array_ref= true;
4374 else if (ref->type == REF_COMPONENT && seen_array_ref)
4378 /* Check for a dependency. */
4379 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4380 expr2->value.function.esym,
4381 expr2->value.function.actual,
4385 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4387 gcc_assert (expr2->value.function.isym
4388 || (gfc_return_by_reference (expr2->value.function.esym)
4389 && expr2->value.function.esym->result->attr.dimension));
4391 ss = gfc_walk_expr (expr1);
4392 gcc_assert (ss != gfc_ss_terminator);
4393 gfc_init_se (&se, NULL);
4394 gfc_start_block (&se.pre);
4395 se.want_pointer = 1;
4397 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
4399 se.direct_byref = 1;
4400 se.ss = gfc_walk_expr (expr2);
4401 gcc_assert (se.ss != gfc_ss_terminator);
4402 gfc_conv_function_expr (&se, expr2);
4403 gfc_add_block_to_block (&se.pre, &se.post);
4405 return gfc_finish_block (&se.pre);
4408 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4411 is_zero_initializer_p (gfc_expr * expr)
4413 if (expr->expr_type != EXPR_CONSTANT)
4416 /* We ignore constants with prescribed memory representations for now. */
4417 if (expr->representation.string)
4420 switch (expr->ts.type)
4423 return mpz_cmp_si (expr->value.integer, 0) == 0;
4426 return mpfr_zero_p (expr->value.real)
4427 && MPFR_SIGN (expr->value.real) >= 0;
4430 return expr->value.logical == 0;
4433 return mpfr_zero_p (expr->value.complex.r)
4434 && MPFR_SIGN (expr->value.complex.r) >= 0
4435 && mpfr_zero_p (expr->value.complex.i)
4436 && MPFR_SIGN (expr->value.complex.i) >= 0;
4444 /* Try to efficiently translate array(:) = 0. Return NULL if this
4448 gfc_trans_zero_assign (gfc_expr * expr)
4450 tree dest, len, type;
4454 sym = expr->symtree->n.sym;
4455 dest = gfc_get_symbol_decl (sym);
4457 type = TREE_TYPE (dest);
4458 if (POINTER_TYPE_P (type))
4459 type = TREE_TYPE (type);
4460 if (!GFC_ARRAY_TYPE_P (type))
4463 /* Determine the length of the array. */
4464 len = GFC_TYPE_ARRAY_SIZE (type);
4465 if (!len || TREE_CODE (len) != INTEGER_CST)
4468 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4469 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4470 fold_convert (gfc_array_index_type, tmp));
4472 /* Convert arguments to the correct types. */
4473 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4474 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4476 dest = fold_convert (pvoid_type_node, dest);
4477 len = fold_convert (size_type_node, len);
4479 /* Construct call to __builtin_memset. */
4480 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4481 3, dest, integer_zero_node, len);
4482 return fold_convert (void_type_node, tmp);
4486 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4487 that constructs the call to __builtin_memcpy. */
4490 gfc_build_memcpy_call (tree dst, tree src, tree len)
4494 /* Convert arguments to the correct types. */
4495 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4496 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4498 dst = fold_convert (pvoid_type_node, dst);
4500 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4501 src = gfc_build_addr_expr (pvoid_type_node, src);
4503 src = fold_convert (pvoid_type_node, src);
4505 len = fold_convert (size_type_node, len);
4507 /* Construct call to __builtin_memcpy. */
4508 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4509 return fold_convert (void_type_node, tmp);
4513 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4514 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4515 source/rhs, both are gfc_full_array_ref_p which have been checked for
4519 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4521 tree dst, dlen, dtype;
4522 tree src, slen, stype;
4525 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4526 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4528 dtype = TREE_TYPE (dst);
4529 if (POINTER_TYPE_P (dtype))
4530 dtype = TREE_TYPE (dtype);
4531 stype = TREE_TYPE (src);
4532 if (POINTER_TYPE_P (stype))
4533 stype = TREE_TYPE (stype);
4535 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4538 /* Determine the lengths of the arrays. */
4539 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4540 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4542 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4543 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4544 fold_convert (gfc_array_index_type, tmp));
4546 slen = GFC_TYPE_ARRAY_SIZE (stype);
4547 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4549 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4550 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4551 fold_convert (gfc_array_index_type, tmp));
4553 /* Sanity check that they are the same. This should always be
4554 the case, as we should already have checked for conformance. */
4555 if (!tree_int_cst_equal (slen, dlen))
4558 return gfc_build_memcpy_call (dst, src, dlen);
4562 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4563 this can't be done. EXPR1 is the destination/lhs for which
4564 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4567 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4569 unsigned HOST_WIDE_INT nelem;
4575 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4579 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4580 dtype = TREE_TYPE (dst);
4581 if (POINTER_TYPE_P (dtype))
4582 dtype = TREE_TYPE (dtype);
4583 if (!GFC_ARRAY_TYPE_P (dtype))
4586 /* Determine the lengths of the array. */
4587 len = GFC_TYPE_ARRAY_SIZE (dtype);
4588 if (!len || TREE_CODE (len) != INTEGER_CST)
4591 /* Confirm that the constructor is the same size. */
4592 if (compare_tree_int (len, nelem) != 0)
4595 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4596 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4597 fold_convert (gfc_array_index_type, tmp));
4599 stype = gfc_typenode_for_spec (&expr2->ts);
4600 src = gfc_build_constant_array_constructor (expr2, stype);
4602 stype = TREE_TYPE (src);
4603 if (POINTER_TYPE_P (stype))
4604 stype = TREE_TYPE (stype);
4606 return gfc_build_memcpy_call (dst, src, len);
4610 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4611 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4614 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4619 gfc_ss *lss_section;
4626 bool scalar_to_array;
4629 /* Assignment of the form lhs = rhs. */
4630 gfc_start_block (&block);
4632 gfc_init_se (&lse, NULL);
4633 gfc_init_se (&rse, NULL);
4636 lss = gfc_walk_expr (expr1);
4638 if (lss != gfc_ss_terminator)
4640 /* Allow the scalarizer to workshare array assignments. */
4641 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4642 ompws_flags |= OMPWS_SCALARIZER_WS;
4644 /* The assignment needs scalarization. */
4647 /* Find a non-scalar SS from the lhs. */
4648 while (lss_section != gfc_ss_terminator
4649 && lss_section->type != GFC_SS_SECTION)
4650 lss_section = lss_section->next;
4652 gcc_assert (lss_section != gfc_ss_terminator);
4654 /* Initialize the scalarizer. */
4655 gfc_init_loopinfo (&loop);
4658 rss = gfc_walk_expr (expr2);
4659 if (rss == gfc_ss_terminator)
4661 /* The rhs is scalar. Add a ss for the expression. */
4662 rss = gfc_get_ss ();
4663 rss->next = gfc_ss_terminator;
4664 rss->type = GFC_SS_SCALAR;
4667 /* Associate the SS with the loop. */
4668 gfc_add_ss_to_loop (&loop, lss);
4669 gfc_add_ss_to_loop (&loop, rss);
4671 /* Calculate the bounds of the scalarization. */
4672 gfc_conv_ss_startstride (&loop);
4673 /* Resolve any data dependencies in the statement. */
4674 gfc_conv_resolve_dependencies (&loop, lss, rss);
4675 /* Setup the scalarizing loops. */
4676 gfc_conv_loop_setup (&loop, &expr2->where);
4678 /* Setup the gfc_se structures. */
4679 gfc_copy_loopinfo_to_se (&lse, &loop);
4680 gfc_copy_loopinfo_to_se (&rse, &loop);
4683 gfc_mark_ss_chain_used (rss, 1);
4684 if (loop.temp_ss == NULL)
4687 gfc_mark_ss_chain_used (lss, 1);
4691 lse.ss = loop.temp_ss;
4692 gfc_mark_ss_chain_used (lss, 3);
4693 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4696 /* Start the scalarized loop body. */
4697 gfc_start_scalarized_body (&loop, &body);
4700 gfc_init_block (&body);
4702 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4704 /* Translate the expression. */
4705 gfc_conv_expr (&rse, expr2);
4707 /* Stabilize a string length for temporaries. */
4708 if (expr2->ts.type == BT_CHARACTER)
4709 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
4711 string_length = NULL_TREE;
4715 gfc_conv_tmp_array_ref (&lse);
4716 gfc_advance_se_ss_chain (&lse);
4717 if (expr2->ts.type == BT_CHARACTER)
4718 lse.string_length = string_length;
4721 gfc_conv_expr (&lse, expr1);
4723 /* Assignments of scalar derived types with allocatable components
4724 to arrays must be done with a deep copy and the rhs temporary
4725 must have its components deallocated afterwards. */
4726 scalar_to_array = (expr2->ts.type == BT_DERIVED
4727 && expr2->ts.derived->attr.alloc_comp
4728 && expr2->expr_type != EXPR_VARIABLE
4729 && !gfc_is_constant_expr (expr2)
4730 && expr1->rank && !expr2->rank);
4731 if (scalar_to_array)
4733 tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
4734 gfc_add_expr_to_block (&loop.post, tmp);
4737 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4738 l_is_temp || init_flag,
4739 (expr2->expr_type == EXPR_VARIABLE)
4740 || scalar_to_array);
4741 gfc_add_expr_to_block (&body, tmp);
4743 if (lss == gfc_ss_terminator)
4745 /* Use the scalar assignment as is. */
4746 gfc_add_block_to_block (&block, &body);
4750 gcc_assert (lse.ss == gfc_ss_terminator
4751 && rse.ss == gfc_ss_terminator);
4755 gfc_trans_scalarized_loop_boundary (&loop, &body);
4757 /* We need to copy the temporary to the actual lhs. */
4758 gfc_init_se (&lse, NULL);
4759 gfc_init_se (&rse, NULL);
4760 gfc_copy_loopinfo_to_se (&lse, &loop);
4761 gfc_copy_loopinfo_to_se (&rse, &loop);
4763 rse.ss = loop.temp_ss;
4766 gfc_conv_tmp_array_ref (&rse);
4767 gfc_advance_se_ss_chain (&rse);
4768 gfc_conv_expr (&lse, expr1);
4770 gcc_assert (lse.ss == gfc_ss_terminator
4771 && rse.ss == gfc_ss_terminator);
4773 if (expr2->ts.type == BT_CHARACTER)
4774 rse.string_length = string_length;
4776 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4778 gfc_add_expr_to_block (&body, tmp);
4781 /* Generate the copying loops. */
4782 gfc_trans_scalarizing_loops (&loop, &body);
4784 /* Wrap the whole thing up. */
4785 gfc_add_block_to_block (&block, &loop.pre);
4786 gfc_add_block_to_block (&block, &loop.post);
4788 gfc_cleanup_loop (&loop);
4791 return gfc_finish_block (&block);
4795 /* Check whether EXPR is a copyable array. */
4798 copyable_array_p (gfc_expr * expr)
4800 if (expr->expr_type != EXPR_VARIABLE)
4803 /* First check it's an array. */
4804 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4807 if (!gfc_full_array_ref_p (expr->ref))
4810 /* Next check that it's of a simple enough type. */
4811 switch (expr->ts.type)
4823 return !expr->ts.derived->attr.alloc_comp;
4832 /* Translate an assignment. */
4835 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4839 /* Special case a single function returning an array. */
4840 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4842 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4847 /* Special case assigning an array to zero. */
4848 if (copyable_array_p (expr1)
4849 && is_zero_initializer_p (expr2))
4851 tmp = gfc_trans_zero_assign (expr1);
4856 /* Special case copying one array to another. */
4857 if (copyable_array_p (expr1)
4858 && copyable_array_p (expr2)
4859 && gfc_compare_types (&expr1->ts, &expr2->ts)
4860 && !gfc_check_dependency (expr1, expr2, 0))
4862 tmp = gfc_trans_array_copy (expr1, expr2);
4867 /* Special case initializing an array from a constant array constructor. */
4868 if (copyable_array_p (expr1)
4869 && expr2->expr_type == EXPR_ARRAY
4870 && gfc_compare_types (&expr1->ts, &expr2->ts))
4872 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4877 /* Fallback to the scalarizer to generate explicit loops. */
4878 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4882 gfc_trans_init_assign (gfc_code * code)
4884 return gfc_trans_assignment (code->expr, code->expr2, true);
4888 gfc_trans_assign (gfc_code * code)
4890 return gfc_trans_assignment (code->expr, code->expr2, false);