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_loc (input_location,
164 /* Test for a NULL value. */
165 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
166 fold_convert (TREE_TYPE (tmp), integer_one_node));
167 tmp = gfc_evaluate_now (tmp, &se->pre);
168 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
172 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
173 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
174 tmp = gfc_evaluate_now (tmp, &se->pre);
178 if (ts.type == BT_CHARACTER)
180 tmp = build_int_cst (gfc_charlen_type_node, 0);
181 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
182 present, se->string_length, tmp);
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->string_length = tmp;
190 /* Get the character length of an expression, looking through gfc_refs
194 gfc_get_expr_charlen (gfc_expr *e)
199 gcc_assert (e->expr_type == EXPR_VARIABLE
200 && e->ts.type == BT_CHARACTER);
202 length = NULL; /* To silence compiler warning. */
204 if (is_subref_array (e) && e->ts.u.cl->length)
207 gfc_init_se (&tmpse, NULL);
208 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
209 e->ts.u.cl->backend_decl = tmpse.expr;
213 /* First candidate: if the variable is of type CHARACTER, the
214 expression's length could be the length of the character
216 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
217 length = e->symtree->n.sym->ts.u.cl->backend_decl;
219 /* Look through the reference chain for component references. */
220 for (r = e->ref; r; r = r->next)
225 if (r->u.c.component->ts.type == BT_CHARACTER)
226 length = r->u.c.component->ts.u.cl->backend_decl;
234 /* We should never got substring references here. These will be
235 broken down by the scalarizer. */
241 gcc_assert (length != NULL);
246 /* For each character array constructor subexpression without a ts.u.cl->length,
247 replace it by its first element (if there aren't any elements, the length
248 should already be set to zero). */
251 flatten_array_ctors_without_strlen (gfc_expr* e)
253 gfc_actual_arglist* arg;
259 switch (e->expr_type)
263 flatten_array_ctors_without_strlen (e->value.op.op1);
264 flatten_array_ctors_without_strlen (e->value.op.op2);
268 /* TODO: Implement as with EXPR_FUNCTION when needed. */
272 for (arg = e->value.function.actual; arg; arg = arg->next)
273 flatten_array_ctors_without_strlen (arg->expr);
278 /* We've found what we're looking for. */
279 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
282 gcc_assert (e->value.constructor);
284 new_expr = e->value.constructor->expr;
285 e->value.constructor->expr = NULL;
287 flatten_array_ctors_without_strlen (new_expr);
288 gfc_replace_expr (e, new_expr);
292 /* Otherwise, fall through to handle constructor elements. */
294 for (c = e->value.constructor; c; c = c->next)
295 flatten_array_ctors_without_strlen (c->expr);
305 /* Generate code to initialize a string length variable. Returns the
306 value. For array constructors, cl->length might be NULL and in this case,
307 the first element of the constructor is needed. expr is the original
308 expression so we can access it but can be NULL if this is not needed. */
311 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
315 gfc_init_se (&se, NULL);
317 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
318 "flatten" array constructors by taking their first element; all elements
319 should be the same length or a cl->length should be present. */
325 expr_flat = gfc_copy_expr (expr);
326 flatten_array_ctors_without_strlen (expr_flat);
327 gfc_resolve_expr (expr_flat);
329 gfc_conv_expr (&se, expr_flat);
330 gfc_add_block_to_block (pblock, &se.pre);
331 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
333 gfc_free_expr (expr_flat);
337 /* Convert cl->length. */
339 gcc_assert (cl->length);
341 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
342 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
343 build_int_cst (gfc_charlen_type_node, 0));
344 gfc_add_block_to_block (pblock, &se.pre);
346 if (cl->backend_decl)
347 gfc_add_modify (pblock, cl->backend_decl, se.expr);
349 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
354 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
355 const char *name, locus *where)
365 type = gfc_get_character_type (kind, ref->u.ss.length);
366 type = build_pointer_type (type);
369 gfc_init_se (&start, se);
370 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
371 gfc_add_block_to_block (&se->pre, &start.pre);
373 if (integer_onep (start.expr))
374 gfc_conv_string_parameter (se);
379 /* Avoid multiple evaluation of substring start. */
380 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
381 start.expr = gfc_evaluate_now (start.expr, &se->pre);
383 /* Change the start of the string. */
384 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
387 tmp = build_fold_indirect_ref_loc (input_location,
389 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
390 se->expr = gfc_build_addr_expr (type, tmp);
393 /* Length = end + 1 - start. */
394 gfc_init_se (&end, se);
395 if (ref->u.ss.end == NULL)
396 end.expr = se->string_length;
399 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
400 gfc_add_block_to_block (&se->pre, &end.pre);
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 end.expr = gfc_evaluate_now (end.expr, &se->pre);
407 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
409 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
410 start.expr, end.expr);
412 /* Check lower bound. */
413 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
414 build_int_cst (gfc_charlen_type_node, 1));
415 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
418 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
419 "is less than one", name);
421 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
423 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
424 fold_convert (long_integer_type_node,
428 /* Check upper bound. */
429 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
431 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
434 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
435 "exceeds string length (%%ld)", name);
437 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
438 "exceeds string length (%%ld)");
439 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
440 fold_convert (long_integer_type_node, end.expr),
441 fold_convert (long_integer_type_node,
446 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
447 end.expr, start.expr);
448 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
449 build_int_cst (gfc_charlen_type_node, 1), tmp);
450 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
451 build_int_cst (gfc_charlen_type_node, 0));
452 se->string_length = tmp;
456 /* Convert a derived type component reference. */
459 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
466 c = ref->u.c.component;
468 gcc_assert (c->backend_decl);
470 field = c->backend_decl;
471 gcc_assert (TREE_CODE (field) == FIELD_DECL);
473 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
477 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
479 tmp = c->ts.u.cl->backend_decl;
480 /* Components must always be constant length. */
481 gcc_assert (tmp && INTEGER_CST_P (tmp));
482 se->string_length = tmp;
485 if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
486 || c->attr.proc_pointer)
487 se->expr = build_fold_indirect_ref_loc (input_location,
492 /* This function deals with component references to components of the
493 parent type for derived type extensons. */
495 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
503 c = ref->u.c.component;
505 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
506 parent.type = REF_COMPONENT;
509 parent.u.c.component = dt->components;
511 if (dt->attr.extension && dt->components)
513 /* Return if the component is not in the parent type. */
514 for (cmp = dt->components->next; cmp; cmp = cmp->next)
515 if (strcmp (c->name, cmp->name) == 0)
518 /* Otherwise build the reference and call self. */
519 gfc_conv_component_ref (se, &parent);
520 parent.u.c.sym = dt->components->ts.u.derived;
521 parent.u.c.component = c;
522 conv_parent_component_references (se, &parent);
526 /* Return the contents of a variable. Also handles reference/pointer
527 variables (all Fortran pointer references are implicit). */
530 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
537 bool alternate_entry;
540 sym = expr->symtree->n.sym;
543 /* Check that something hasn't gone horribly wrong. */
544 gcc_assert (se->ss != gfc_ss_terminator);
545 gcc_assert (se->ss->expr == expr);
547 /* A scalarized term. We already know the descriptor. */
548 se->expr = se->ss->data.info.descriptor;
549 se->string_length = se->ss->string_length;
550 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
551 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
556 tree se_expr = NULL_TREE;
558 se->expr = gfc_get_symbol_decl (sym);
560 /* Deal with references to a parent results or entries by storing
561 the current_function_decl and moving to the parent_decl. */
562 return_value = sym->attr.function && sym->result == sym;
563 alternate_entry = sym->attr.function && sym->attr.entry
564 && sym->result == sym;
565 entry_master = sym->attr.result
566 && sym->ns->proc_name->attr.entry_master
567 && !gfc_return_by_reference (sym->ns->proc_name);
568 parent_decl = DECL_CONTEXT (current_function_decl);
570 if ((se->expr == parent_decl && return_value)
571 || (sym->ns && sym->ns->proc_name
573 && sym->ns->proc_name->backend_decl == parent_decl
574 && (alternate_entry || entry_master)))
579 /* Special case for assigning the return value of a function.
580 Self recursive functions must have an explicit return value. */
581 if (return_value && (se->expr == current_function_decl || parent_flag))
582 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
584 /* Similarly for alternate entry points. */
585 else if (alternate_entry
586 && (sym->ns->proc_name->backend_decl == current_function_decl
589 gfc_entry_list *el = NULL;
591 for (el = sym->ns->entries; el; el = el->next)
594 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
599 else if (entry_master
600 && (sym->ns->proc_name->backend_decl == current_function_decl
602 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
607 /* Procedure actual arguments. */
608 else if (sym->attr.flavor == FL_PROCEDURE
609 && se->expr != current_function_decl)
611 if (!sym->attr.dummy && !sym->attr.proc_pointer)
613 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
614 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
620 /* Dereference the expression, where needed. Since characters
621 are entirely different from other types, they are treated
623 if (sym->ts.type == BT_CHARACTER)
625 /* Dereference character pointer dummy arguments
627 if ((sym->attr.pointer || sym->attr.allocatable)
629 || sym->attr.function
630 || sym->attr.result))
631 se->expr = build_fold_indirect_ref_loc (input_location,
635 else if (!sym->attr.value)
637 /* Dereference non-character scalar dummy arguments. */
638 if (sym->attr.dummy && !sym->attr.dimension)
639 se->expr = build_fold_indirect_ref_loc (input_location,
642 /* Dereference scalar hidden result. */
643 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
644 && (sym->attr.function || sym->attr.result)
645 && !sym->attr.dimension && !sym->attr.pointer
646 && !sym->attr.always_explicit)
647 se->expr = build_fold_indirect_ref_loc (input_location,
650 /* Dereference non-character pointer variables.
651 These must be dummies, results, or scalars. */
652 if ((sym->attr.pointer || sym->attr.allocatable)
654 || sym->attr.function
656 || !sym->attr.dimension))
657 se->expr = build_fold_indirect_ref_loc (input_location,
664 /* For character variables, also get the length. */
665 if (sym->ts.type == BT_CHARACTER)
667 /* If the character length of an entry isn't set, get the length from
668 the master function instead. */
669 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
670 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
672 se->string_length = sym->ts.u.cl->backend_decl;
673 gcc_assert (se->string_length);
681 /* Return the descriptor if that's what we want and this is an array
682 section reference. */
683 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
685 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
686 /* Return the descriptor for array pointers and allocations. */
688 && ref->next == NULL && (se->descriptor_only))
691 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
692 /* Return a pointer to an element. */
696 if (ref->u.c.sym->attr.extension)
697 conv_parent_component_references (se, ref);
699 gfc_conv_component_ref (se, ref);
703 gfc_conv_substring (se, ref, expr->ts.kind,
704 expr->symtree->name, &expr->where);
713 /* Pointer assignment, allocation or pass by reference. Arrays are handled
715 if (se->want_pointer)
717 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
718 gfc_conv_string_parameter (se);
720 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
725 /* Unary ops are easy... Or they would be if ! was a valid op. */
728 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
733 gcc_assert (expr->ts.type != BT_CHARACTER);
734 /* Initialize the operand. */
735 gfc_init_se (&operand, se);
736 gfc_conv_expr_val (&operand, expr->value.op.op1);
737 gfc_add_block_to_block (&se->pre, &operand.pre);
739 type = gfc_typenode_for_spec (&expr->ts);
741 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
742 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
743 All other unary operators have an equivalent GIMPLE unary operator. */
744 if (code == TRUTH_NOT_EXPR)
745 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
746 build_int_cst (type, 0));
748 se->expr = fold_build1 (code, type, operand.expr);
752 /* Expand power operator to optimal multiplications when a value is raised
753 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
754 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
755 Programming", 3rd Edition, 1998. */
757 /* This code is mostly duplicated from expand_powi in the backend.
758 We establish the "optimal power tree" lookup table with the defined size.
759 The items in the table are the exponents used to calculate the index
760 exponents. Any integer n less than the value can get an "addition chain",
761 with the first node being one. */
762 #define POWI_TABLE_SIZE 256
764 /* The table is from builtins.c. */
765 static const unsigned char powi_table[POWI_TABLE_SIZE] =
767 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
768 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
769 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
770 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
771 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
772 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
773 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
774 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
775 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
776 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
777 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
778 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
779 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
780 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
781 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
782 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
783 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
784 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
785 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
786 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
787 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
788 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
789 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
790 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
791 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
792 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
793 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
794 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
795 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
796 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
797 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
798 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
801 /* If n is larger than lookup table's max index, we use the "window
803 #define POWI_WINDOW_SIZE 3
805 /* Recursive function to expand the power operator. The temporary
806 values are put in tmpvar. The function returns tmpvar[1] ** n. */
808 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
815 if (n < POWI_TABLE_SIZE)
820 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
821 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
825 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
826 op0 = gfc_conv_powi (se, n - digit, tmpvar);
827 op1 = gfc_conv_powi (se, digit, tmpvar);
831 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
835 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
836 tmp = gfc_evaluate_now (tmp, &se->pre);
838 if (n < POWI_TABLE_SIZE)
845 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
846 return 1. Else return 0 and a call to runtime library functions
847 will have to be built. */
849 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
854 tree vartmp[POWI_TABLE_SIZE];
856 unsigned HOST_WIDE_INT n;
859 /* If exponent is too large, we won't expand it anyway, so don't bother
860 with large integer values. */
861 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
864 m = double_int_to_shwi (TREE_INT_CST (rhs));
865 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
866 of the asymmetric range of the integer type. */
867 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
869 type = TREE_TYPE (lhs);
870 sgn = tree_int_cst_sgn (rhs);
872 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
873 || optimize_size) && (m > 2 || m < -1))
879 se->expr = gfc_build_const (type, integer_one_node);
883 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
884 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
886 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
887 lhs, build_int_cst (TREE_TYPE (lhs), -1));
888 cond = fold_build2 (EQ_EXPR, boolean_type_node,
889 lhs, build_int_cst (TREE_TYPE (lhs), 1));
892 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
895 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
896 se->expr = fold_build3 (COND_EXPR, type,
897 tmp, build_int_cst (type, 1),
898 build_int_cst (type, 0));
902 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
903 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
904 build_int_cst (type, 0));
905 se->expr = fold_build3 (COND_EXPR, type,
906 cond, build_int_cst (type, 1), tmp);
910 memset (vartmp, 0, sizeof (vartmp));
914 tmp = gfc_build_const (type, integer_one_node);
915 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
918 se->expr = gfc_conv_powi (se, n, vartmp);
924 /* Power op (**). Constant integer exponent has special handling. */
927 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
929 tree gfc_int4_type_node;
936 gfc_init_se (&lse, se);
937 gfc_conv_expr_val (&lse, expr->value.op.op1);
938 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
939 gfc_add_block_to_block (&se->pre, &lse.pre);
941 gfc_init_se (&rse, se);
942 gfc_conv_expr_val (&rse, expr->value.op.op2);
943 gfc_add_block_to_block (&se->pre, &rse.pre);
945 if (expr->value.op.op2->ts.type == BT_INTEGER
946 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
947 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
950 gfc_int4_type_node = gfc_get_int_type (4);
952 kind = expr->value.op.op1->ts.kind;
953 switch (expr->value.op.op2->ts.type)
956 ikind = expr->value.op.op2->ts.kind;
961 rse.expr = convert (gfc_int4_type_node, rse.expr);
983 if (expr->value.op.op1->ts.type == BT_INTEGER)
984 lse.expr = convert (gfc_int4_type_node, lse.expr);
1009 switch (expr->value.op.op1->ts.type)
1012 if (kind == 3) /* Case 16 was not handled properly above. */
1014 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1018 /* Use builtins for real ** int4. */
1024 fndecl = built_in_decls[BUILT_IN_POWIF];
1028 fndecl = built_in_decls[BUILT_IN_POWI];
1033 fndecl = built_in_decls[BUILT_IN_POWIL];
1041 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1045 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1057 fndecl = built_in_decls[BUILT_IN_POWF];
1060 fndecl = built_in_decls[BUILT_IN_POW];
1064 fndecl = built_in_decls[BUILT_IN_POWL];
1075 fndecl = built_in_decls[BUILT_IN_CPOWF];
1078 fndecl = built_in_decls[BUILT_IN_CPOW];
1082 fndecl = built_in_decls[BUILT_IN_CPOWL];
1094 se->expr = build_call_expr_loc (input_location,
1095 fndecl, 2, lse.expr, rse.expr);
1099 /* Generate code to allocate a string temporary. */
1102 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1107 gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
1109 if (gfc_can_put_var_on_stack (len))
1111 /* Create a temporary variable to hold the result. */
1112 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1113 build_int_cst (gfc_charlen_type_node, 1));
1114 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1116 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1117 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1119 tmp = build_array_type (TREE_TYPE (type), tmp);
1121 var = gfc_create_var (tmp, "str");
1122 var = gfc_build_addr_expr (type, var);
1126 /* Allocate a temporary to hold the result. */
1127 var = gfc_create_var (type, "pstr");
1128 tmp = gfc_call_malloc (&se->pre, type,
1129 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1130 fold_convert (TREE_TYPE (len),
1131 TYPE_SIZE (type))));
1132 gfc_add_modify (&se->pre, var, tmp);
1134 /* Free the temporary afterwards. */
1135 tmp = gfc_call_free (convert (pvoid_type_node, var));
1136 gfc_add_expr_to_block (&se->post, tmp);
1143 /* Handle a string concatenation operation. A temporary will be allocated to
1147 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1150 tree len, type, var, tmp, fndecl;
1152 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1153 && expr->value.op.op2->ts.type == BT_CHARACTER);
1154 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1156 gfc_init_se (&lse, se);
1157 gfc_conv_expr (&lse, expr->value.op.op1);
1158 gfc_conv_string_parameter (&lse);
1159 gfc_init_se (&rse, se);
1160 gfc_conv_expr (&rse, expr->value.op.op2);
1161 gfc_conv_string_parameter (&rse);
1163 gfc_add_block_to_block (&se->pre, &lse.pre);
1164 gfc_add_block_to_block (&se->pre, &rse.pre);
1166 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1167 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1168 if (len == NULL_TREE)
1170 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1171 lse.string_length, rse.string_length);
1174 type = build_pointer_type (type);
1176 var = gfc_conv_string_tmp (se, type, len);
1178 /* Do the actual concatenation. */
1179 if (expr->ts.kind == 1)
1180 fndecl = gfor_fndecl_concat_string;
1181 else if (expr->ts.kind == 4)
1182 fndecl = gfor_fndecl_concat_string_char4;
1186 tmp = build_call_expr_loc (input_location,
1187 fndecl, 6, len, var, lse.string_length, lse.expr,
1188 rse.string_length, rse.expr);
1189 gfc_add_expr_to_block (&se->pre, tmp);
1191 /* Add the cleanup for the operands. */
1192 gfc_add_block_to_block (&se->pre, &rse.post);
1193 gfc_add_block_to_block (&se->pre, &lse.post);
1196 se->string_length = len;
1199 /* Translates an op expression. Common (binary) cases are handled by this
1200 function, others are passed on. Recursion is used in either case.
1201 We use the fact that (op1.ts == op2.ts) (except for the power
1203 Operators need no special handling for scalarized expressions as long as
1204 they call gfc_conv_simple_val to get their operands.
1205 Character strings get special handling. */
1208 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1210 enum tree_code code;
1219 switch (expr->value.op.op)
1221 case INTRINSIC_PARENTHESES:
1222 if (expr->ts.type == BT_REAL
1223 || expr->ts.type == BT_COMPLEX)
1225 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1226 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1231 case INTRINSIC_UPLUS:
1232 gfc_conv_expr (se, expr->value.op.op1);
1235 case INTRINSIC_UMINUS:
1236 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1240 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1243 case INTRINSIC_PLUS:
1247 case INTRINSIC_MINUS:
1251 case INTRINSIC_TIMES:
1255 case INTRINSIC_DIVIDE:
1256 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1257 an integer, we must round towards zero, so we use a
1259 if (expr->ts.type == BT_INTEGER)
1260 code = TRUNC_DIV_EXPR;
1265 case INTRINSIC_POWER:
1266 gfc_conv_power_op (se, expr);
1269 case INTRINSIC_CONCAT:
1270 gfc_conv_concat_op (se, expr);
1274 code = TRUTH_ANDIF_EXPR;
1279 code = TRUTH_ORIF_EXPR;
1283 /* EQV and NEQV only work on logicals, but since we represent them
1284 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1286 case INTRINSIC_EQ_OS:
1294 case INTRINSIC_NE_OS:
1295 case INTRINSIC_NEQV:
1302 case INTRINSIC_GT_OS:
1309 case INTRINSIC_GE_OS:
1316 case INTRINSIC_LT_OS:
1323 case INTRINSIC_LE_OS:
1329 case INTRINSIC_USER:
1330 case INTRINSIC_ASSIGN:
1331 /* These should be converted into function calls by the frontend. */
1335 fatal_error ("Unknown intrinsic op");
1339 /* The only exception to this is **, which is handled separately anyway. */
1340 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1342 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1346 gfc_init_se (&lse, se);
1347 gfc_conv_expr (&lse, expr->value.op.op1);
1348 gfc_add_block_to_block (&se->pre, &lse.pre);
1351 gfc_init_se (&rse, se);
1352 gfc_conv_expr (&rse, expr->value.op.op2);
1353 gfc_add_block_to_block (&se->pre, &rse.pre);
1357 gfc_conv_string_parameter (&lse);
1358 gfc_conv_string_parameter (&rse);
1360 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1361 rse.string_length, rse.expr,
1362 expr->value.op.op1->ts.kind);
1363 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1364 gfc_add_block_to_block (&lse.post, &rse.post);
1367 type = gfc_typenode_for_spec (&expr->ts);
1371 /* The result of logical ops is always boolean_type_node. */
1372 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1373 se->expr = convert (type, tmp);
1376 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1378 /* Add the post blocks. */
1379 gfc_add_block_to_block (&se->post, &rse.post);
1380 gfc_add_block_to_block (&se->post, &lse.post);
1383 /* If a string's length is one, we convert it to a single character. */
1386 string_to_single_character (tree len, tree str, int kind)
1388 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1390 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1391 && TREE_INT_CST_HIGH (len) == 0)
1393 str = fold_convert (gfc_get_pchar_type (kind), str);
1394 return build_fold_indirect_ref_loc (input_location,
1403 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1406 if (sym->backend_decl)
1408 /* This becomes the nominal_type in
1409 function.c:assign_parm_find_data_types. */
1410 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1411 /* This becomes the passed_type in
1412 function.c:assign_parm_find_data_types. C promotes char to
1413 integer for argument passing. */
1414 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1416 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1421 /* If we have a constant character expression, make it into an
1423 if ((*expr)->expr_type == EXPR_CONSTANT)
1428 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1429 if ((*expr)->ts.kind != gfc_c_int_kind)
1431 /* The expr needs to be compatible with a C int. If the
1432 conversion fails, then the 2 causes an ICE. */
1433 ts.type = BT_INTEGER;
1434 ts.kind = gfc_c_int_kind;
1435 gfc_convert_type (*expr, &ts, 2);
1438 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1440 if ((*expr)->ref == NULL)
1442 se->expr = string_to_single_character
1443 (build_int_cst (integer_type_node, 1),
1444 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1446 ((*expr)->symtree->n.sym)),
1451 gfc_conv_variable (se, *expr);
1452 se->expr = string_to_single_character
1453 (build_int_cst (integer_type_node, 1),
1454 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1463 /* Compare two strings. If they are all single characters, the result is the
1464 subtraction of them. Otherwise, we build a library call. */
1467 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1473 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1474 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1476 sc1 = string_to_single_character (len1, str1, kind);
1477 sc2 = string_to_single_character (len2, str2, kind);
1479 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1481 /* Deal with single character specially. */
1482 sc1 = fold_convert (integer_type_node, sc1);
1483 sc2 = fold_convert (integer_type_node, sc2);
1484 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1488 /* Build a call for the comparison. */
1492 fndecl = gfor_fndecl_compare_string;
1494 fndecl = gfor_fndecl_compare_string_char4;
1498 tmp = build_call_expr_loc (input_location,
1499 fndecl, 4, len1, str1, len2, str2);
1506 /* Return the backend_decl for a procedure pointer component. */
1509 get_proc_ptr_comp (gfc_expr *e)
1513 gfc_init_se (&comp_se, NULL);
1514 e2 = gfc_copy_expr (e);
1515 e2->expr_type = EXPR_VARIABLE;
1516 gfc_conv_expr (&comp_se, e2);
1517 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1522 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1526 if (gfc_is_proc_ptr_comp (expr, NULL))
1527 tmp = get_proc_ptr_comp (expr);
1528 else if (sym->attr.dummy)
1530 tmp = gfc_get_symbol_decl (sym);
1531 if (sym->attr.proc_pointer)
1532 tmp = build_fold_indirect_ref_loc (input_location,
1534 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1535 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1539 if (!sym->backend_decl)
1540 sym->backend_decl = gfc_get_extern_function_decl (sym);
1542 tmp = sym->backend_decl;
1544 if (sym->attr.cray_pointee)
1546 /* TODO - make the cray pointee a pointer to a procedure,
1547 assign the pointer to it and use it for the call. This
1549 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1550 gfc_get_symbol_decl (sym->cp_pointer));
1551 tmp = gfc_evaluate_now (tmp, &se->pre);
1554 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1556 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1557 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1564 /* Initialize MAPPING. */
1567 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1569 mapping->syms = NULL;
1570 mapping->charlens = NULL;
1574 /* Free all memory held by MAPPING (but not MAPPING itself). */
1577 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1579 gfc_interface_sym_mapping *sym;
1580 gfc_interface_sym_mapping *nextsym;
1582 gfc_charlen *nextcl;
1584 for (sym = mapping->syms; sym; sym = nextsym)
1586 nextsym = sym->next;
1587 sym->new_sym->n.sym->formal = NULL;
1588 gfc_free_symbol (sym->new_sym->n.sym);
1589 gfc_free_expr (sym->expr);
1590 gfc_free (sym->new_sym);
1593 for (cl = mapping->charlens; cl; cl = nextcl)
1596 gfc_free_expr (cl->length);
1602 /* Return a copy of gfc_charlen CL. Add the returned structure to
1603 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1605 static gfc_charlen *
1606 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1609 gfc_charlen *new_charlen;
1611 new_charlen = gfc_get_charlen ();
1612 new_charlen->next = mapping->charlens;
1613 new_charlen->length = gfc_copy_expr (cl->length);
1615 mapping->charlens = new_charlen;
1620 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1621 array variable that can be used as the actual argument for dummy
1622 argument SYM. Add any initialization code to BLOCK. PACKED is as
1623 for gfc_get_nodesc_array_type and DATA points to the first element
1624 in the passed array. */
1627 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1628 gfc_packed packed, tree data)
1633 type = gfc_typenode_for_spec (&sym->ts);
1634 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1635 !sym->attr.target && !sym->attr.pointer
1636 && !sym->attr.proc_pointer);
1638 var = gfc_create_var (type, "ifm");
1639 gfc_add_modify (block, var, fold_convert (type, data));
1645 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1646 and offset of descriptorless array type TYPE given that it has the same
1647 size as DESC. Add any set-up code to BLOCK. */
1650 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1657 offset = gfc_index_zero_node;
1658 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1660 dim = gfc_rank_cst[n];
1661 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1662 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1664 GFC_TYPE_ARRAY_LBOUND (type, n)
1665 = gfc_conv_descriptor_lbound_get (desc, dim);
1666 GFC_TYPE_ARRAY_UBOUND (type, n)
1667 = gfc_conv_descriptor_ubound_get (desc, dim);
1669 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1671 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1672 gfc_conv_descriptor_ubound_get (desc, dim),
1673 gfc_conv_descriptor_lbound_get (desc, dim));
1674 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1675 GFC_TYPE_ARRAY_LBOUND (type, n),
1677 tmp = gfc_evaluate_now (tmp, block);
1678 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1680 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1681 GFC_TYPE_ARRAY_LBOUND (type, n),
1682 GFC_TYPE_ARRAY_STRIDE (type, n));
1683 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1685 offset = gfc_evaluate_now (offset, block);
1686 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1690 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1691 in SE. The caller may still use se->expr and se->string_length after
1692 calling this function. */
1695 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1696 gfc_symbol * sym, gfc_se * se,
1699 gfc_interface_sym_mapping *sm;
1703 gfc_symbol *new_sym;
1705 gfc_symtree *new_symtree;
1707 /* Create a new symbol to represent the actual argument. */
1708 new_sym = gfc_new_symbol (sym->name, NULL);
1709 new_sym->ts = sym->ts;
1710 new_sym->as = gfc_copy_array_spec (sym->as);
1711 new_sym->attr.referenced = 1;
1712 new_sym->attr.dimension = sym->attr.dimension;
1713 new_sym->attr.pointer = sym->attr.pointer;
1714 new_sym->attr.allocatable = sym->attr.allocatable;
1715 new_sym->attr.flavor = sym->attr.flavor;
1716 new_sym->attr.function = sym->attr.function;
1718 /* Ensure that the interface is available and that
1719 descriptors are passed for array actual arguments. */
1720 if (sym->attr.flavor == FL_PROCEDURE)
1722 new_sym->formal = expr->symtree->n.sym->formal;
1723 new_sym->attr.always_explicit
1724 = expr->symtree->n.sym->attr.always_explicit;
1727 /* Create a fake symtree for it. */
1729 new_symtree = gfc_new_symtree (&root, sym->name);
1730 new_symtree->n.sym = new_sym;
1731 gcc_assert (new_symtree == root);
1733 /* Create a dummy->actual mapping. */
1734 sm = XCNEW (gfc_interface_sym_mapping);
1735 sm->next = mapping->syms;
1737 sm->new_sym = new_symtree;
1738 sm->expr = gfc_copy_expr (expr);
1741 /* Stabilize the argument's value. */
1742 if (!sym->attr.function && se)
1743 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1745 if (sym->ts.type == BT_CHARACTER)
1747 /* Create a copy of the dummy argument's length. */
1748 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1749 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1751 /* If the length is specified as "*", record the length that
1752 the caller is passing. We should use the callee's length
1753 in all other cases. */
1754 if (!new_sym->ts.u.cl->length && se)
1756 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1757 new_sym->ts.u.cl->backend_decl = se->string_length;
1764 /* Use the passed value as-is if the argument is a function. */
1765 if (sym->attr.flavor == FL_PROCEDURE)
1768 /* If the argument is either a string or a pointer to a string,
1769 convert it to a boundless character type. */
1770 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1772 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1773 tmp = build_pointer_type (tmp);
1774 if (sym->attr.pointer)
1775 value = build_fold_indirect_ref_loc (input_location,
1779 value = fold_convert (tmp, value);
1782 /* If the argument is a scalar, a pointer to an array or an allocatable,
1784 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1785 value = build_fold_indirect_ref_loc (input_location,
1788 /* For character(*), use the actual argument's descriptor. */
1789 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1790 value = build_fold_indirect_ref_loc (input_location,
1793 /* If the argument is an array descriptor, use it to determine
1794 information about the actual argument's shape. */
1795 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1796 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1798 /* Get the actual argument's descriptor. */
1799 desc = build_fold_indirect_ref_loc (input_location,
1802 /* Create the replacement variable. */
1803 tmp = gfc_conv_descriptor_data_get (desc);
1804 value = gfc_get_interface_mapping_array (&se->pre, sym,
1807 /* Use DESC to work out the upper bounds, strides and offset. */
1808 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1811 /* Otherwise we have a packed array. */
1812 value = gfc_get_interface_mapping_array (&se->pre, sym,
1813 PACKED_FULL, se->expr);
1815 new_sym->backend_decl = value;
1819 /* Called once all dummy argument mappings have been added to MAPPING,
1820 but before the mapping is used to evaluate expressions. Pre-evaluate
1821 the length of each argument, adding any initialization code to PRE and
1822 any finalization code to POST. */
1825 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1826 stmtblock_t * pre, stmtblock_t * post)
1828 gfc_interface_sym_mapping *sym;
1832 for (sym = mapping->syms; sym; sym = sym->next)
1833 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1834 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1836 expr = sym->new_sym->n.sym->ts.u.cl->length;
1837 gfc_apply_interface_mapping_to_expr (mapping, expr);
1838 gfc_init_se (&se, NULL);
1839 gfc_conv_expr (&se, expr);
1840 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1841 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1842 gfc_add_block_to_block (pre, &se.pre);
1843 gfc_add_block_to_block (post, &se.post);
1845 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1850 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1854 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1855 gfc_constructor * c)
1857 for (; c; c = c->next)
1859 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1862 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1863 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1864 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1870 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1874 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1879 for (; ref; ref = ref->next)
1883 for (n = 0; n < ref->u.ar.dimen; n++)
1885 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1886 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1887 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1889 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1896 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1897 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1903 /* Convert intrinsic function calls into result expressions. */
1906 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1914 arg1 = expr->value.function.actual->expr;
1915 if (expr->value.function.actual->next)
1916 arg2 = expr->value.function.actual->next->expr;
1920 sym = arg1->symtree->n.sym;
1922 if (sym->attr.dummy)
1927 switch (expr->value.function.isym->id)
1930 /* TODO figure out why this condition is necessary. */
1931 if (sym->attr.function
1932 && (arg1->ts.u.cl->length == NULL
1933 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
1934 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
1937 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
1944 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1946 dup = mpz_get_si (arg2->value.integer);
1951 dup = sym->as->rank;
1955 for (; d < dup; d++)
1959 if (!sym->as->upper[d] || !sym->as->lower[d])
1961 gfc_free_expr (new_expr);
1965 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1966 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1968 new_expr = gfc_multiply (new_expr, tmp);
1974 case GFC_ISYM_LBOUND:
1975 case GFC_ISYM_UBOUND:
1976 /* TODO These implementations of lbound and ubound do not limit if
1977 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1982 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1983 d = mpz_get_si (arg2->value.integer) - 1;
1985 /* TODO: If the need arises, this could produce an array of
1989 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1991 if (sym->as->lower[d])
1992 new_expr = gfc_copy_expr (sym->as->lower[d]);
1996 if (sym->as->upper[d])
1997 new_expr = gfc_copy_expr (sym->as->upper[d]);
2005 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2009 gfc_replace_expr (expr, new_expr);
2015 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2016 gfc_interface_mapping * mapping)
2018 gfc_formal_arglist *f;
2019 gfc_actual_arglist *actual;
2021 actual = expr->value.function.actual;
2022 f = map_expr->symtree->n.sym->formal;
2024 for (; f && actual; f = f->next, actual = actual->next)
2029 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2032 if (map_expr->symtree->n.sym->attr.dimension)
2037 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2039 for (d = 0; d < as->rank; d++)
2041 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2042 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2045 expr->value.function.esym->as = as;
2048 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2050 expr->value.function.esym->ts.u.cl->length
2051 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2053 gfc_apply_interface_mapping_to_expr (mapping,
2054 expr->value.function.esym->ts.u.cl->length);
2059 /* EXPR is a copy of an expression that appeared in the interface
2060 associated with MAPPING. Walk it recursively looking for references to
2061 dummy arguments that MAPPING maps to actual arguments. Replace each such
2062 reference with a reference to the associated actual argument. */
2065 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2068 gfc_interface_sym_mapping *sym;
2069 gfc_actual_arglist *actual;
2074 /* Copying an expression does not copy its length, so do that here. */
2075 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2077 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2078 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2081 /* Apply the mapping to any references. */
2082 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2084 /* ...and to the expression's symbol, if it has one. */
2085 /* TODO Find out why the condition on expr->symtree had to be moved into
2086 the loop rather than being outside it, as originally. */
2087 for (sym = mapping->syms; sym; sym = sym->next)
2088 if (expr->symtree && sym->old == expr->symtree->n.sym)
2090 if (sym->new_sym->n.sym->backend_decl)
2091 expr->symtree = sym->new_sym;
2093 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2096 /* ...and to subexpressions in expr->value. */
2097 switch (expr->expr_type)
2102 case EXPR_SUBSTRING:
2106 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2107 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2111 for (actual = expr->value.function.actual; actual; actual = actual->next)
2112 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2114 if (expr->value.function.esym == NULL
2115 && expr->value.function.isym != NULL
2116 && expr->value.function.actual->expr->symtree
2117 && gfc_map_intrinsic_function (expr, mapping))
2120 for (sym = mapping->syms; sym; sym = sym->next)
2121 if (sym->old == expr->value.function.esym)
2123 expr->value.function.esym = sym->new_sym->n.sym;
2124 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2125 expr->value.function.esym->result = sym->new_sym->n.sym;
2130 case EXPR_STRUCTURE:
2131 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2144 /* Evaluate interface expression EXPR using MAPPING. Store the result
2148 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2149 gfc_se * se, gfc_expr * expr)
2151 expr = gfc_copy_expr (expr);
2152 gfc_apply_interface_mapping_to_expr (mapping, expr);
2153 gfc_conv_expr (se, expr);
2154 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2155 gfc_free_expr (expr);
2159 /* Returns a reference to a temporary array into which a component of
2160 an actual argument derived type array is copied and then returned
2161 after the function call. */
2163 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2164 int g77, sym_intent intent)
2180 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2182 gfc_init_se (&lse, NULL);
2183 gfc_init_se (&rse, NULL);
2185 /* Walk the argument expression. */
2186 rss = gfc_walk_expr (expr);
2188 gcc_assert (rss != gfc_ss_terminator);
2190 /* Initialize the scalarizer. */
2191 gfc_init_loopinfo (&loop);
2192 gfc_add_ss_to_loop (&loop, rss);
2194 /* Calculate the bounds of the scalarization. */
2195 gfc_conv_ss_startstride (&loop);
2197 /* Build an ss for the temporary. */
2198 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2199 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2201 base_type = gfc_typenode_for_spec (&expr->ts);
2202 if (GFC_ARRAY_TYPE_P (base_type)
2203 || GFC_DESCRIPTOR_TYPE_P (base_type))
2204 base_type = gfc_get_element_type (base_type);
2206 loop.temp_ss = gfc_get_ss ();;
2207 loop.temp_ss->type = GFC_SS_TEMP;
2208 loop.temp_ss->data.temp.type = base_type;
2210 if (expr->ts.type == BT_CHARACTER)
2211 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2213 loop.temp_ss->string_length = NULL;
2215 parmse->string_length = loop.temp_ss->string_length;
2216 loop.temp_ss->data.temp.dimen = loop.dimen;
2217 loop.temp_ss->next = gfc_ss_terminator;
2219 /* Associate the SS with the loop. */
2220 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2222 /* Setup the scalarizing loops. */
2223 gfc_conv_loop_setup (&loop, &expr->where);
2225 /* Pass the temporary descriptor back to the caller. */
2226 info = &loop.temp_ss->data.info;
2227 parmse->expr = info->descriptor;
2229 /* Setup the gfc_se structures. */
2230 gfc_copy_loopinfo_to_se (&lse, &loop);
2231 gfc_copy_loopinfo_to_se (&rse, &loop);
2234 lse.ss = loop.temp_ss;
2235 gfc_mark_ss_chain_used (rss, 1);
2236 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2238 /* Start the scalarized loop body. */
2239 gfc_start_scalarized_body (&loop, &body);
2241 /* Translate the expression. */
2242 gfc_conv_expr (&rse, expr);
2244 gfc_conv_tmp_array_ref (&lse);
2245 gfc_advance_se_ss_chain (&lse);
2247 if (intent != INTENT_OUT)
2249 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2250 gfc_add_expr_to_block (&body, tmp);
2251 gcc_assert (rse.ss == gfc_ss_terminator);
2252 gfc_trans_scalarizing_loops (&loop, &body);
2256 /* Make sure that the temporary declaration survives by merging
2257 all the loop declarations into the current context. */
2258 for (n = 0; n < loop.dimen; n++)
2260 gfc_merge_block_scope (&body);
2261 body = loop.code[loop.order[n]];
2263 gfc_merge_block_scope (&body);
2266 /* Add the post block after the second loop, so that any
2267 freeing of allocated memory is done at the right time. */
2268 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2270 /**********Copy the temporary back again.*********/
2272 gfc_init_se (&lse, NULL);
2273 gfc_init_se (&rse, NULL);
2275 /* Walk the argument expression. */
2276 lss = gfc_walk_expr (expr);
2277 rse.ss = loop.temp_ss;
2280 /* Initialize the scalarizer. */
2281 gfc_init_loopinfo (&loop2);
2282 gfc_add_ss_to_loop (&loop2, lss);
2284 /* Calculate the bounds of the scalarization. */
2285 gfc_conv_ss_startstride (&loop2);
2287 /* Setup the scalarizing loops. */
2288 gfc_conv_loop_setup (&loop2, &expr->where);
2290 gfc_copy_loopinfo_to_se (&lse, &loop2);
2291 gfc_copy_loopinfo_to_se (&rse, &loop2);
2293 gfc_mark_ss_chain_used (lss, 1);
2294 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2296 /* Declare the variable to hold the temporary offset and start the
2297 scalarized loop body. */
2298 offset = gfc_create_var (gfc_array_index_type, NULL);
2299 gfc_start_scalarized_body (&loop2, &body);
2301 /* Build the offsets for the temporary from the loop variables. The
2302 temporary array has lbounds of zero and strides of one in all
2303 dimensions, so this is very simple. The offset is only computed
2304 outside the innermost loop, so the overall transfer could be
2305 optimized further. */
2306 info = &rse.ss->data.info;
2308 tmp_index = gfc_index_zero_node;
2309 for (n = info->dimen - 1; n > 0; n--)
2312 tmp = rse.loop->loopvar[n];
2313 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2314 tmp, rse.loop->from[n]);
2315 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2318 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2319 rse.loop->to[n-1], rse.loop->from[n-1]);
2320 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2321 tmp_str, gfc_index_one_node);
2323 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2327 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2328 tmp_index, rse.loop->from[0]);
2329 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2331 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2332 rse.loop->loopvar[0], offset);
2334 /* Now use the offset for the reference. */
2335 tmp = build_fold_indirect_ref_loc (input_location,
2337 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2339 if (expr->ts.type == BT_CHARACTER)
2340 rse.string_length = expr->ts.u.cl->backend_decl;
2342 gfc_conv_expr (&lse, expr);
2344 gcc_assert (lse.ss == gfc_ss_terminator);
2346 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2347 gfc_add_expr_to_block (&body, tmp);
2349 /* Generate the copying loops. */
2350 gfc_trans_scalarizing_loops (&loop2, &body);
2352 /* Wrap the whole thing up by adding the second loop to the post-block
2353 and following it by the post-block of the first loop. In this way,
2354 if the temporary needs freeing, it is done after use! */
2355 if (intent != INTENT_IN)
2357 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2358 gfc_add_block_to_block (&parmse->post, &loop2.post);
2361 gfc_add_block_to_block (&parmse->post, &loop.post);
2363 gfc_cleanup_loop (&loop);
2364 gfc_cleanup_loop (&loop2);
2366 /* Pass the string length to the argument expression. */
2367 if (expr->ts.type == BT_CHARACTER)
2368 parmse->string_length = expr->ts.u.cl->backend_decl;
2370 /* We want either the address for the data or the address of the descriptor,
2371 depending on the mode of passing array arguments. */
2373 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2375 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2381 /* Generate the code for argument list functions. */
2384 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2386 /* Pass by value for g77 %VAL(arg), pass the address
2387 indirectly for %LOC, else by reference. Thus %REF
2388 is a "do-nothing" and %LOC is the same as an F95
2390 if (strncmp (name, "%VAL", 4) == 0)
2391 gfc_conv_expr (se, expr);
2392 else if (strncmp (name, "%LOC", 4) == 0)
2394 gfc_conv_expr_reference (se, expr);
2395 se->expr = gfc_build_addr_expr (NULL, se->expr);
2397 else if (strncmp (name, "%REF", 4) == 0)
2398 gfc_conv_expr_reference (se, expr);
2400 gfc_error ("Unknown argument list function at %L", &expr->where);
2404 /* Generate code for a procedure call. Note can return se->post != NULL.
2405 If se->direct_byref is set then se->expr contains the return parameter.
2406 Return nonzero, if the call has alternate specifiers.
2407 'expr' is only needed for procedure pointer components. */
2410 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2411 gfc_actual_arglist * arg, gfc_expr * expr,
2414 gfc_interface_mapping mapping;
2428 gfc_formal_arglist *formal;
2429 int has_alternate_specifier = 0;
2430 bool need_interface_mapping;
2437 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2438 gfc_component *comp = NULL;
2440 arglist = NULL_TREE;
2441 retargs = NULL_TREE;
2442 stringargs = NULL_TREE;
2447 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2449 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2451 if (arg->expr->rank == 0)
2452 gfc_conv_expr_reference (se, arg->expr);
2456 /* This is really the actual arg because no formal arglist is
2457 created for C_LOC. */
2458 fsym = arg->expr->symtree->n.sym;
2460 /* We should want it to do g77 calling convention. */
2462 && !(fsym->attr.pointer || fsym->attr.allocatable)
2463 && fsym->as->type != AS_ASSUMED_SHAPE;
2464 f = f || !sym->attr.always_explicit;
2466 argss = gfc_walk_expr (arg->expr);
2467 gfc_conv_array_parameter (se, arg->expr, argss, f,
2471 /* TODO -- the following two lines shouldn't be necessary, but
2472 they're removed a bug is exposed later in the codepath.
2473 This is workaround was thus introduced, but will have to be
2474 removed; please see PR 35150 for details about the issue. */
2475 se->expr = convert (pvoid_type_node, se->expr);
2476 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2480 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2482 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2483 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2484 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2485 gfc_conv_expr_reference (se, arg->expr);
2489 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2490 && arg->next->expr->rank == 0)
2491 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2493 /* Convert c_f_pointer if fptr is a scalar
2494 and convert c_f_procpointer. */
2498 gfc_init_se (&cptrse, NULL);
2499 gfc_conv_expr (&cptrse, arg->expr);
2500 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2501 gfc_add_block_to_block (&se->post, &cptrse.post);
2503 gfc_init_se (&fptrse, NULL);
2504 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2505 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2506 fptrse.want_pointer = 1;
2508 gfc_conv_expr (&fptrse, arg->next->expr);
2509 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2510 gfc_add_block_to_block (&se->post, &fptrse.post);
2512 if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2513 tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
2515 tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
2516 se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
2517 fold_convert (tmp, cptrse.expr));
2521 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2526 /* Build the addr_expr for the first argument. The argument is
2527 already an *address* so we don't need to set want_pointer in
2529 gfc_init_se (&arg1se, NULL);
2530 gfc_conv_expr (&arg1se, arg->expr);
2531 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2532 gfc_add_block_to_block (&se->post, &arg1se.post);
2534 /* See if we were given two arguments. */
2535 if (arg->next == NULL)
2536 /* Only given one arg so generate a null and do a
2537 not-equal comparison against the first arg. */
2538 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2539 fold_convert (TREE_TYPE (arg1se.expr),
2540 null_pointer_node));
2546 /* Given two arguments so build the arg2se from second arg. */
2547 gfc_init_se (&arg2se, NULL);
2548 gfc_conv_expr (&arg2se, arg->next->expr);
2549 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2550 gfc_add_block_to_block (&se->post, &arg2se.post);
2552 /* Generate test to compare that the two args are equal. */
2553 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2554 arg1se.expr, arg2se.expr);
2555 /* Generate test to ensure that the first arg is not null. */
2556 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2557 arg1se.expr, null_pointer_node);
2559 /* Finally, the generated test must check that both arg1 is not
2560 NULL and that it is equal to the second arg. */
2561 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2562 not_null_expr, eq_expr);
2569 gfc_is_proc_ptr_comp (expr, &comp);
2573 if (!sym->attr.elemental)
2575 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2576 if (se->ss->useflags)
2578 gcc_assert ((!comp && gfc_return_by_reference (sym)
2579 && sym->result->attr.dimension)
2580 || (comp && comp->attr.dimension));
2581 gcc_assert (se->loop != NULL);
2583 /* Access the previously obtained result. */
2584 gfc_conv_tmp_array_ref (se);
2585 gfc_advance_se_ss_chain (se);
2589 info = &se->ss->data.info;
2594 gfc_init_block (&post);
2595 gfc_init_interface_mapping (&mapping);
2598 formal = sym->formal;
2599 need_interface_mapping = sym->attr.dimension ||
2600 (sym->ts.type == BT_CHARACTER
2601 && sym->ts.u.cl->length
2602 && sym->ts.u.cl->length->expr_type
2607 formal = comp->formal;
2608 need_interface_mapping = comp->attr.dimension ||
2609 (comp->ts.type == BT_CHARACTER
2610 && comp->ts.u.cl->length
2611 && comp->ts.u.cl->length->expr_type
2615 /* Evaluate the arguments. */
2616 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2619 fsym = formal ? formal->sym : NULL;
2620 parm_kind = MISSING;
2624 if (se->ignore_optional)
2626 /* Some intrinsics have already been resolved to the correct
2630 else if (arg->label)
2632 has_alternate_specifier = 1;
2637 /* Pass a NULL pointer for an absent arg. */
2638 gfc_init_se (&parmse, NULL);
2639 parmse.expr = null_pointer_node;
2640 if (arg->missing_arg_type == BT_CHARACTER)
2641 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2644 else if (se->ss && se->ss->useflags)
2646 /* An elemental function inside a scalarized loop. */
2647 gfc_init_se (&parmse, se);
2648 gfc_conv_expr_reference (&parmse, e);
2649 parm_kind = ELEMENTAL;
2653 /* A scalar or transformational function. */
2654 gfc_init_se (&parmse, NULL);
2655 argss = gfc_walk_expr (e);
2657 if (argss == gfc_ss_terminator)
2659 if (e->expr_type == EXPR_VARIABLE
2660 && e->symtree->n.sym->attr.cray_pointee
2661 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2663 /* The Cray pointer needs to be converted to a pointer to
2664 a type given by the expression. */
2665 gfc_conv_expr (&parmse, e);
2666 type = build_pointer_type (TREE_TYPE (parmse.expr));
2667 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2668 parmse.expr = convert (type, tmp);
2670 else if (fsym && fsym->attr.value)
2672 if (fsym->ts.type == BT_CHARACTER
2673 && fsym->ts.is_c_interop
2674 && fsym->ns->proc_name != NULL
2675 && fsym->ns->proc_name->attr.is_bind_c)
2678 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2679 if (parmse.expr == NULL)
2680 gfc_conv_expr (&parmse, e);
2683 gfc_conv_expr (&parmse, e);
2685 else if (arg->name && arg->name[0] == '%')
2686 /* Argument list functions %VAL, %LOC and %REF are signalled
2687 through arg->name. */
2688 conv_arglist_function (&parmse, arg->expr, arg->name);
2689 else if ((e->expr_type == EXPR_FUNCTION)
2690 && e->symtree->n.sym->attr.pointer
2691 && fsym && fsym->attr.target)
2693 gfc_conv_expr (&parmse, e);
2694 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2696 else if (e->expr_type == EXPR_FUNCTION
2697 && e->symtree->n.sym->result
2698 && e->symtree->n.sym->result != e->symtree->n.sym
2699 && e->symtree->n.sym->result->attr.proc_pointer)
2701 /* Functions returning procedure pointers. */
2702 gfc_conv_expr (&parmse, e);
2703 if (fsym && fsym->attr.proc_pointer)
2704 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2708 gfc_conv_expr_reference (&parmse, e);
2709 if (fsym && e->expr_type != EXPR_NULL
2710 && ((fsym->attr.pointer
2711 && fsym->attr.flavor != FL_PROCEDURE)
2712 || (fsym->attr.proc_pointer
2713 && !(e->expr_type == EXPR_VARIABLE
2714 && e->symtree->n.sym->attr.dummy))
2715 || (e->expr_type == EXPR_VARIABLE
2716 && gfc_is_proc_ptr_comp (e, NULL))))
2718 /* Scalar pointer dummy args require an extra level of
2719 indirection. The null pointer already contains
2720 this level of indirection. */
2721 parm_kind = SCALAR_POINTER;
2722 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2728 /* If the procedure requires an explicit interface, the actual
2729 argument is passed according to the corresponding formal
2730 argument. If the corresponding formal argument is a POINTER,
2731 ALLOCATABLE or assumed shape, we do not use g77's calling
2732 convention, and pass the address of the array descriptor
2733 instead. Otherwise we use g77's calling convention. */
2736 && !(fsym->attr.pointer || fsym->attr.allocatable)
2737 && fsym->as->type != AS_ASSUMED_SHAPE;
2738 f = f || !sym->attr.always_explicit;
2740 if (e->expr_type == EXPR_VARIABLE
2741 && is_subref_array (e))
2742 /* The actual argument is a component reference to an
2743 array of derived types. In this case, the argument
2744 is converted to a temporary, which is passed and then
2745 written back after the procedure call. */
2746 gfc_conv_subref_array_arg (&parmse, e, f,
2747 fsym ? fsym->attr.intent : INTENT_INOUT);
2749 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2752 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2753 allocated on entry, it must be deallocated. */
2754 if (fsym && fsym->attr.allocatable
2755 && fsym->attr.intent == INTENT_OUT)
2757 tmp = build_fold_indirect_ref_loc (input_location,
2759 tmp = gfc_trans_dealloc_allocated (tmp);
2760 gfc_add_expr_to_block (&se->pre, tmp);
2766 /* The case with fsym->attr.optional is that of a user subroutine
2767 with an interface indicating an optional argument. When we call
2768 an intrinsic subroutine, however, fsym is NULL, but we might still
2769 have an optional argument, so we proceed to the substitution
2771 if (e && (fsym == NULL || fsym->attr.optional))
2773 /* If an optional argument is itself an optional dummy argument,
2774 check its presence and substitute a null if absent. */
2775 if (e->expr_type == EXPR_VARIABLE
2776 && e->symtree->n.sym->attr.optional)
2777 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2778 e->representation.length);
2783 /* Obtain the character length of an assumed character length
2784 length procedure from the typespec. */
2785 if (fsym->ts.type == BT_CHARACTER
2786 && parmse.string_length == NULL_TREE
2787 && e->ts.type == BT_PROCEDURE
2788 && e->symtree->n.sym->ts.type == BT_CHARACTER
2789 && e->symtree->n.sym->ts.u.cl->length != NULL
2790 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2792 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
2793 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
2797 if (fsym && need_interface_mapping && e)
2798 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2800 gfc_add_block_to_block (&se->pre, &parmse.pre);
2801 gfc_add_block_to_block (&post, &parmse.post);
2803 /* Allocated allocatable components of derived types must be
2804 deallocated for non-variable scalars. Non-variable arrays are
2805 dealt with in trans-array.c(gfc_conv_array_parameter). */
2806 if (e && e->ts.type == BT_DERIVED
2807 && e->ts.u.derived->attr.alloc_comp
2808 && !(e->symtree && e->symtree->n.sym->attr.pointer)
2809 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2812 tmp = build_fold_indirect_ref_loc (input_location,
2814 parm_rank = e->rank;
2822 case (SCALAR_POINTER):
2823 tmp = build_fold_indirect_ref_loc (input_location,
2828 if (e->expr_type == EXPR_OP
2829 && e->value.op.op == INTRINSIC_PARENTHESES
2830 && e->value.op.op1->expr_type == EXPR_VARIABLE)
2833 local_tmp = gfc_evaluate_now (tmp, &se->pre);
2834 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
2835 gfc_add_expr_to_block (&se->post, local_tmp);
2838 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
2840 gfc_add_expr_to_block (&se->post, tmp);
2843 /* Add argument checking of passing an unallocated/NULL actual to
2844 a nonallocatable/nonpointer dummy. */
2846 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
2848 symbol_attribute *attr;
2852 if (e->expr_type == EXPR_VARIABLE)
2853 attr = &e->symtree->n.sym->attr;
2854 else if (e->expr_type == EXPR_FUNCTION)
2856 /* For intrinsic functions, the gfc_attr are not available. */
2857 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
2858 goto end_pointer_check;
2860 if (e->symtree->n.sym->attr.generic)
2861 attr = &e->value.function.esym->attr;
2863 attr = &e->symtree->n.sym->result->attr;
2866 goto end_pointer_check;
2870 /* If the actual argument is an optional pointer/allocatable and
2871 the formal argument takes an nonpointer optional value,
2872 it is invalid to pass a non-present argument on, even
2873 though there is no technical reason for this in gfortran.
2874 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
2875 tree present, nullptr, type;
2877 if (attr->allocatable
2878 && (fsym == NULL || !fsym->attr.allocatable))
2879 asprintf (&msg, "Allocatable actual argument '%s' is not "
2880 "allocated or not present", e->symtree->n.sym->name);
2881 else if (attr->pointer
2882 && (fsym == NULL || !fsym->attr.pointer))
2883 asprintf (&msg, "Pointer actual argument '%s' is not "
2884 "associated or not present",
2885 e->symtree->n.sym->name);
2886 else if (attr->proc_pointer
2887 && (fsym == NULL || !fsym->attr.proc_pointer))
2888 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2889 "associated or not present",
2890 e->symtree->n.sym->name);
2892 goto end_pointer_check;
2894 present = gfc_conv_expr_present (e->symtree->n.sym);
2895 type = TREE_TYPE (present);
2896 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
2897 fold_convert (type, null_pointer_node));
2898 type = TREE_TYPE (parmse.expr);
2899 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2900 fold_convert (type, null_pointer_node));
2901 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
2906 if (attr->allocatable
2907 && (fsym == NULL || !fsym->attr.allocatable))
2908 asprintf (&msg, "Allocatable actual argument '%s' is not "
2909 "allocated", e->symtree->n.sym->name);
2910 else if (attr->pointer
2911 && (fsym == NULL || !fsym->attr.pointer))
2912 asprintf (&msg, "Pointer actual argument '%s' is not "
2913 "associated", e->symtree->n.sym->name);
2914 else if (attr->proc_pointer
2915 && (fsym == NULL || !fsym->attr.proc_pointer))
2916 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2917 "associated", e->symtree->n.sym->name);
2919 goto end_pointer_check;
2922 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2923 fold_convert (TREE_TYPE (parmse.expr),
2924 null_pointer_node));
2927 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
2934 /* Character strings are passed as two parameters, a length and a
2935 pointer - except for Bind(c) which only passes the pointer. */
2936 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2937 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2939 arglist = gfc_chainon_list (arglist, parmse.expr);
2941 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2948 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2949 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2950 else if (ts.type == BT_CHARACTER)
2952 if (ts.u.cl->length == NULL)
2954 /* Assumed character length results are not allowed by 5.1.1.5 of the
2955 standard and are trapped in resolve.c; except in the case of SPREAD
2956 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2957 we take the character length of the first argument for the result.
2958 For dummies, we have to look through the formal argument list for
2959 this function and use the character length found there.*/
2960 if (!sym->attr.dummy)
2961 cl.backend_decl = TREE_VALUE (stringargs);
2964 formal = sym->ns->proc_name->formal;
2965 for (; formal; formal = formal->next)
2966 if (strcmp (formal->sym->name, sym->name) == 0)
2967 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
2974 /* Calculate the length of the returned string. */
2975 gfc_init_se (&parmse, NULL);
2976 if (need_interface_mapping)
2977 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
2979 gfc_conv_expr (&parmse, ts.u.cl->length);
2980 gfc_add_block_to_block (&se->pre, &parmse.pre);
2981 gfc_add_block_to_block (&se->post, &parmse.post);
2983 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2984 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2985 build_int_cst (gfc_charlen_type_node, 0));
2986 cl.backend_decl = tmp;
2989 /* Set up a charlen structure for it. */
2994 len = cl.backend_decl;
2997 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
2998 || (!comp && gfc_return_by_reference (sym));
3001 if (se->direct_byref)
3003 /* Sometimes, too much indirection can be applied; e.g. for
3004 function_result = array_valued_recursive_function. */
3005 if (TREE_TYPE (TREE_TYPE (se->expr))
3006 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3007 && GFC_DESCRIPTOR_TYPE_P
3008 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3009 se->expr = build_fold_indirect_ref_loc (input_location,
3012 retargs = gfc_chainon_list (retargs, se->expr);
3014 else if (comp && comp->attr.dimension)
3016 gcc_assert (se->loop && info);
3018 /* Set the type of the array. */
3019 tmp = gfc_typenode_for_spec (&comp->ts);
3020 info->dimen = se->loop->dimen;
3022 /* Evaluate the bounds of the result, if known. */
3023 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3025 /* Create a temporary to store the result. In case the function
3026 returns a pointer, the temporary will be a shallow copy and
3027 mustn't be deallocated. */
3028 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3029 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3030 NULL_TREE, false, !comp->attr.pointer,
3031 callee_alloc, &se->ss->expr->where);
3033 /* Pass the temporary as the first argument. */
3034 tmp = info->descriptor;
3035 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3036 retargs = gfc_chainon_list (retargs, tmp);
3038 else if (!comp && sym->result->attr.dimension)
3040 gcc_assert (se->loop && info);
3042 /* Set the type of the array. */
3043 tmp = gfc_typenode_for_spec (&ts);
3044 info->dimen = se->loop->dimen;
3046 /* Evaluate the bounds of the result, if known. */
3047 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3049 /* Create a temporary to store the result. In case the function
3050 returns a pointer, the temporary will be a shallow copy and
3051 mustn't be deallocated. */
3052 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3053 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3054 NULL_TREE, false, !sym->attr.pointer,
3055 callee_alloc, &se->ss->expr->where);
3057 /* Pass the temporary as the first argument. */
3058 tmp = info->descriptor;
3059 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3060 retargs = gfc_chainon_list (retargs, tmp);
3062 else if (ts.type == BT_CHARACTER)
3064 /* Pass the string length. */
3065 type = gfc_get_character_type (ts.kind, ts.u.cl);
3066 type = build_pointer_type (type);
3068 /* Return an address to a char[0:len-1]* temporary for
3069 character pointers. */
3070 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3071 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3073 var = gfc_create_var (type, "pstr");
3075 /* Provide an address expression for the function arguments. */
3076 var = gfc_build_addr_expr (NULL_TREE, var);
3079 var = gfc_conv_string_tmp (se, type, len);
3081 retargs = gfc_chainon_list (retargs, var);
3085 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3087 type = gfc_get_complex_type (ts.kind);
3088 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3089 retargs = gfc_chainon_list (retargs, var);
3092 /* Add the string length to the argument list. */
3093 if (ts.type == BT_CHARACTER)
3094 retargs = gfc_chainon_list (retargs, len);
3096 gfc_free_interface_mapping (&mapping);
3098 /* Add the return arguments. */
3099 arglist = chainon (retargs, arglist);
3101 /* Add the hidden string length parameters to the arguments. */
3102 arglist = chainon (arglist, stringargs);
3104 /* We may want to append extra arguments here. This is used e.g. for
3105 calls to libgfortran_matmul_??, which need extra information. */
3106 if (append_args != NULL_TREE)
3107 arglist = chainon (arglist, append_args);
3109 /* Generate the actual call. */
3110 conv_function_val (se, sym, expr);
3112 /* If there are alternate return labels, function type should be
3113 integer. Can't modify the type in place though, since it can be shared
3114 with other functions. For dummy arguments, the typing is done to
3115 to this result, even if it has to be repeated for each call. */
3116 if (has_alternate_specifier
3117 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3119 if (!sym->attr.dummy)
3121 TREE_TYPE (sym->backend_decl)
3122 = build_function_type (integer_type_node,
3123 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3124 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3127 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3130 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3131 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3133 /* If we have a pointer function, but we don't want a pointer, e.g.
3136 where f is pointer valued, we have to dereference the result. */
3137 if (!se->want_pointer && !byref && sym->attr.pointer
3138 && !gfc_is_proc_ptr_comp (expr, NULL))
3139 se->expr = build_fold_indirect_ref_loc (input_location,
3142 /* f2c calling conventions require a scalar default real function to
3143 return a double precision result. Convert this back to default
3144 real. We only care about the cases that can happen in Fortran 77.
3146 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3147 && sym->ts.kind == gfc_default_real_kind
3148 && !sym->attr.always_explicit)
3149 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3151 /* A pure function may still have side-effects - it may modify its
3153 TREE_SIDE_EFFECTS (se->expr) = 1;
3155 if (!sym->attr.pure)
3156 TREE_SIDE_EFFECTS (se->expr) = 1;
3161 /* Add the function call to the pre chain. There is no expression. */
3162 gfc_add_expr_to_block (&se->pre, se->expr);
3163 se->expr = NULL_TREE;
3165 if (!se->direct_byref)
3167 if (sym->attr.dimension || (comp && comp->attr.dimension))
3169 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3171 /* Check the data pointer hasn't been modified. This would
3172 happen in a function returning a pointer. */
3173 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3174 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3176 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3179 se->expr = info->descriptor;
3180 /* Bundle in the string length. */
3181 se->string_length = len;
3183 else if (ts.type == BT_CHARACTER)
3185 /* Dereference for character pointer results. */
3186 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3187 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3188 se->expr = build_fold_indirect_ref_loc (input_location, var);
3192 se->string_length = len;
3196 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3197 se->expr = build_fold_indirect_ref_loc (input_location, var);
3202 /* Follow the function call with the argument post block. */
3204 gfc_add_block_to_block (&se->pre, &post);
3206 gfc_add_block_to_block (&se->post, &post);
3208 return has_alternate_specifier;
3212 /* Fill a character string with spaces. */
3215 fill_with_spaces (tree start, tree type, tree size)
3217 stmtblock_t block, loop;
3218 tree i, el, exit_label, cond, tmp;
3220 /* For a simple char type, we can call memset(). */
3221 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3222 return build_call_expr_loc (input_location,
3223 built_in_decls[BUILT_IN_MEMSET], 3, start,
3224 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3225 lang_hooks.to_target_charset (' ')),
3228 /* Otherwise, we use a loop:
3229 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3233 /* Initialize variables. */
3234 gfc_init_block (&block);
3235 i = gfc_create_var (sizetype, "i");
3236 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3237 el = gfc_create_var (build_pointer_type (type), "el");
3238 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3239 exit_label = gfc_build_label_decl (NULL_TREE);
3240 TREE_USED (exit_label) = 1;
3244 gfc_init_block (&loop);
3246 /* Exit condition. */
3247 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3248 fold_convert (sizetype, integer_zero_node));
3249 tmp = build1_v (GOTO_EXPR, exit_label);
3250 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3251 build_empty_stmt (input_location));
3252 gfc_add_expr_to_block (&loop, tmp);
3255 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3256 build_int_cst (type,
3257 lang_hooks.to_target_charset (' ')));
3259 /* Increment loop variables. */
3260 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3261 TYPE_SIZE_UNIT (type)));
3262 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3264 TYPE_SIZE_UNIT (type)));
3266 /* Making the loop... actually loop! */
3267 tmp = gfc_finish_block (&loop);
3268 tmp = build1_v (LOOP_EXPR, tmp);
3269 gfc_add_expr_to_block (&block, tmp);
3271 /* The exit label. */
3272 tmp = build1_v (LABEL_EXPR, exit_label);
3273 gfc_add_expr_to_block (&block, tmp);
3276 return gfc_finish_block (&block);
3280 /* Generate code to copy a string. */
3283 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3284 int dkind, tree slength, tree src, int skind)
3286 tree tmp, dlen, slen;
3295 stmtblock_t tempblock;
3297 gcc_assert (dkind == skind);
3299 if (slength != NULL_TREE)
3301 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3302 ssc = string_to_single_character (slen, src, skind);
3306 slen = build_int_cst (size_type_node, 1);
3310 if (dlength != NULL_TREE)
3312 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3313 dsc = string_to_single_character (slen, dest, dkind);
3317 dlen = build_int_cst (size_type_node, 1);
3321 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3322 ssc = string_to_single_character (slen, src, skind);
3323 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3324 dsc = string_to_single_character (dlen, dest, dkind);
3327 /* Assign directly if the types are compatible. */
3328 if (dsc != NULL_TREE && ssc != NULL_TREE
3329 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3331 gfc_add_modify (block, dsc, ssc);
3335 /* Do nothing if the destination length is zero. */
3336 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3337 build_int_cst (size_type_node, 0));
3339 /* The following code was previously in _gfortran_copy_string:
3341 // The two strings may overlap so we use memmove.
3343 copy_string (GFC_INTEGER_4 destlen, char * dest,
3344 GFC_INTEGER_4 srclen, const char * src)
3346 if (srclen >= destlen)
3348 // This will truncate if too long.
3349 memmove (dest, src, destlen);
3353 memmove (dest, src, srclen);
3355 memset (&dest[srclen], ' ', destlen - srclen);
3359 We're now doing it here for better optimization, but the logic
3362 /* For non-default character kinds, we have to multiply the string
3363 length by the base type size. */
3364 chartype = gfc_get_char_type (dkind);
3365 slen = fold_build2 (MULT_EXPR, size_type_node,
3366 fold_convert (size_type_node, slen),
3367 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3368 dlen = fold_build2 (MULT_EXPR, size_type_node,
3369 fold_convert (size_type_node, dlen),
3370 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3373 dest = fold_convert (pvoid_type_node, dest);
3375 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3378 src = fold_convert (pvoid_type_node, src);
3380 src = gfc_build_addr_expr (pvoid_type_node, src);
3382 /* Truncate string if source is too long. */
3383 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3384 tmp2 = build_call_expr_loc (input_location,
3385 built_in_decls[BUILT_IN_MEMMOVE],
3386 3, dest, src, dlen);
3388 /* Else copy and pad with spaces. */
3389 tmp3 = build_call_expr_loc (input_location,
3390 built_in_decls[BUILT_IN_MEMMOVE],
3391 3, dest, src, slen);
3393 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3394 fold_convert (sizetype, slen));
3395 tmp4 = fill_with_spaces (tmp4, chartype,
3396 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3399 gfc_init_block (&tempblock);
3400 gfc_add_expr_to_block (&tempblock, tmp3);
3401 gfc_add_expr_to_block (&tempblock, tmp4);
3402 tmp3 = gfc_finish_block (&tempblock);
3404 /* The whole copy_string function is there. */
3405 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3406 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3407 build_empty_stmt (input_location));
3408 gfc_add_expr_to_block (block, tmp);
3412 /* Translate a statement function.
3413 The value of a statement function reference is obtained by evaluating the
3414 expression using the values of the actual arguments for the values of the
3415 corresponding dummy arguments. */
3418 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3422 gfc_formal_arglist *fargs;
3423 gfc_actual_arglist *args;
3426 gfc_saved_var *saved_vars;
3432 sym = expr->symtree->n.sym;
3433 args = expr->value.function.actual;
3434 gfc_init_se (&lse, NULL);
3435 gfc_init_se (&rse, NULL);
3438 for (fargs = sym->formal; fargs; fargs = fargs->next)
3440 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3441 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3443 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3445 /* Each dummy shall be specified, explicitly or implicitly, to be
3447 gcc_assert (fargs->sym->attr.dimension == 0);
3450 /* Create a temporary to hold the value. */
3451 type = gfc_typenode_for_spec (&fsym->ts);
3452 temp_vars[n] = gfc_create_var (type, fsym->name);
3454 if (fsym->ts.type == BT_CHARACTER)
3456 /* Copy string arguments. */
3459 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3460 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3462 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3463 tmp = gfc_build_addr_expr (build_pointer_type (type),
3466 gfc_conv_expr (&rse, args->expr);
3467 gfc_conv_string_parameter (&rse);
3468 gfc_add_block_to_block (&se->pre, &lse.pre);
3469 gfc_add_block_to_block (&se->pre, &rse.pre);
3471 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3472 rse.string_length, rse.expr, fsym->ts.kind);
3473 gfc_add_block_to_block (&se->pre, &lse.post);
3474 gfc_add_block_to_block (&se->pre, &rse.post);
3478 /* For everything else, just evaluate the expression. */
3479 gfc_conv_expr (&lse, args->expr);
3481 gfc_add_block_to_block (&se->pre, &lse.pre);
3482 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3483 gfc_add_block_to_block (&se->pre, &lse.post);
3489 /* Use the temporary variables in place of the real ones. */
3490 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3491 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3493 gfc_conv_expr (se, sym->value);
3495 if (sym->ts.type == BT_CHARACTER)
3497 gfc_conv_const_charlen (sym->ts.u.cl);
3499 /* Force the expression to the correct length. */
3500 if (!INTEGER_CST_P (se->string_length)
3501 || tree_int_cst_lt (se->string_length,
3502 sym->ts.u.cl->backend_decl))
3504 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3505 tmp = gfc_create_var (type, sym->name);
3506 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3507 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3508 sym->ts.kind, se->string_length, se->expr,
3512 se->string_length = sym->ts.u.cl->backend_decl;
3515 /* Restore the original variables. */
3516 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3517 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3518 gfc_free (saved_vars);
3522 /* Translate a function expression. */
3525 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3529 if (expr->value.function.isym)
3531 gfc_conv_intrinsic_function (se, expr);
3535 /* We distinguish statement functions from general functions to improve
3536 runtime performance. */
3537 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3539 gfc_conv_statement_function (se, expr);
3543 /* expr.value.function.esym is the resolved (specific) function symbol for
3544 most functions. However this isn't set for dummy procedures. */
3545 sym = expr->value.function.esym;
3547 sym = expr->symtree->n.sym;
3549 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3555 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3557 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3558 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3560 gfc_conv_tmp_array_ref (se);
3561 gfc_advance_se_ss_chain (se);
3565 /* Build a static initializer. EXPR is the expression for the initial value.
3566 The other parameters describe the variable of the component being
3567 initialized. EXPR may be null. */
3570 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3571 bool array, bool pointer)
3575 if (!(expr || pointer))
3578 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3579 (these are the only two iso_c_binding derived types that can be
3580 used as initialization expressions). If so, we need to modify
3581 the 'expr' to be that for a (void *). */
3582 if (expr != NULL && expr->ts.type == BT_DERIVED
3583 && expr->ts.is_iso_c && expr->ts.u.derived)
3585 gfc_symbol *derived = expr->ts.u.derived;
3587 expr = gfc_int_expr (0);
3589 /* The derived symbol has already been converted to a (void *). Use
3591 expr->ts.f90_type = derived->ts.f90_type;
3592 expr->ts.kind = derived->ts.kind;
3597 /* Arrays need special handling. */
3599 return gfc_build_null_descriptor (type);
3601 return gfc_conv_array_initializer (type, expr);
3604 return fold_convert (type, null_pointer_node);
3610 gfc_init_se (&se, NULL);
3611 gfc_conv_structure (&se, expr, 1);
3615 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3618 gfc_init_se (&se, NULL);
3619 gfc_conv_constant (&se, expr);
3626 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3638 gfc_start_block (&block);
3640 /* Initialize the scalarizer. */
3641 gfc_init_loopinfo (&loop);
3643 gfc_init_se (&lse, NULL);
3644 gfc_init_se (&rse, NULL);
3647 rss = gfc_walk_expr (expr);
3648 if (rss == gfc_ss_terminator)
3650 /* The rhs is scalar. Add a ss for the expression. */
3651 rss = gfc_get_ss ();
3652 rss->next = gfc_ss_terminator;
3653 rss->type = GFC_SS_SCALAR;
3657 /* Create a SS for the destination. */
3658 lss = gfc_get_ss ();
3659 lss->type = GFC_SS_COMPONENT;
3661 lss->shape = gfc_get_shape (cm->as->rank);
3662 lss->next = gfc_ss_terminator;
3663 lss->data.info.dimen = cm->as->rank;
3664 lss->data.info.descriptor = dest;
3665 lss->data.info.data = gfc_conv_array_data (dest);
3666 lss->data.info.offset = gfc_conv_array_offset (dest);
3667 for (n = 0; n < cm->as->rank; n++)
3669 lss->data.info.dim[n] = n;
3670 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3671 lss->data.info.stride[n] = gfc_index_one_node;
3673 mpz_init (lss->shape[n]);
3674 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3675 cm->as->lower[n]->value.integer);
3676 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3679 /* Associate the SS with the loop. */
3680 gfc_add_ss_to_loop (&loop, lss);
3681 gfc_add_ss_to_loop (&loop, rss);
3683 /* Calculate the bounds of the scalarization. */
3684 gfc_conv_ss_startstride (&loop);
3686 /* Setup the scalarizing loops. */
3687 gfc_conv_loop_setup (&loop, &expr->where);
3689 /* Setup the gfc_se structures. */
3690 gfc_copy_loopinfo_to_se (&lse, &loop);
3691 gfc_copy_loopinfo_to_se (&rse, &loop);
3694 gfc_mark_ss_chain_used (rss, 1);
3696 gfc_mark_ss_chain_used (lss, 1);
3698 /* Start the scalarized loop body. */
3699 gfc_start_scalarized_body (&loop, &body);
3701 gfc_conv_tmp_array_ref (&lse);
3702 if (cm->ts.type == BT_CHARACTER)
3703 lse.string_length = cm->ts.u.cl->backend_decl;
3705 gfc_conv_expr (&rse, expr);
3707 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3708 gfc_add_expr_to_block (&body, tmp);
3710 gcc_assert (rse.ss == gfc_ss_terminator);
3712 /* Generate the copying loops. */
3713 gfc_trans_scalarizing_loops (&loop, &body);
3715 /* Wrap the whole thing up. */
3716 gfc_add_block_to_block (&block, &loop.pre);
3717 gfc_add_block_to_block (&block, &loop.post);
3719 for (n = 0; n < cm->as->rank; n++)
3720 mpz_clear (lss->shape[n]);
3721 gfc_free (lss->shape);
3723 gfc_cleanup_loop (&loop);
3725 return gfc_finish_block (&block);
3729 /* Assign a single component of a derived type constructor. */
3732 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3742 gfc_start_block (&block);
3744 if (cm->attr.pointer)
3746 gfc_init_se (&se, NULL);
3747 /* Pointer component. */
3748 if (cm->attr.dimension)
3750 /* Array pointer. */
3751 if (expr->expr_type == EXPR_NULL)
3752 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3755 rss = gfc_walk_expr (expr);
3756 se.direct_byref = 1;
3758 gfc_conv_expr_descriptor (&se, expr, rss);
3759 gfc_add_block_to_block (&block, &se.pre);
3760 gfc_add_block_to_block (&block, &se.post);
3765 /* Scalar pointers. */
3766 se.want_pointer = 1;
3767 gfc_conv_expr (&se, expr);
3768 gfc_add_block_to_block (&block, &se.pre);
3769 gfc_add_modify (&block, dest,
3770 fold_convert (TREE_TYPE (dest), se.expr));
3771 gfc_add_block_to_block (&block, &se.post);
3774 else if (cm->attr.dimension)
3776 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3777 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3778 else if (cm->attr.allocatable)
3782 gfc_init_se (&se, NULL);
3784 rss = gfc_walk_expr (expr);
3785 se.want_pointer = 0;
3786 gfc_conv_expr_descriptor (&se, expr, rss);
3787 gfc_add_block_to_block (&block, &se.pre);
3788 gfc_add_modify (&block, dest, se.expr);
3790 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
3791 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
3794 tmp = gfc_duplicate_allocatable (dest, se.expr,
3795 TREE_TYPE(cm->backend_decl),
3798 gfc_add_expr_to_block (&block, tmp);
3799 gfc_add_block_to_block (&block, &se.post);
3801 if (expr->expr_type != EXPR_VARIABLE)
3802 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3804 /* Shift the lbound and ubound of temporaries to being unity, rather
3805 than zero, based. Calculate the offset for all cases. */
3806 offset = gfc_conv_descriptor_offset_get (dest);
3807 gfc_add_modify (&block, offset, gfc_index_zero_node);
3808 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3809 for (n = 0; n < expr->rank; n++)
3811 if (expr->expr_type != EXPR_VARIABLE
3812 && expr->expr_type != EXPR_CONSTANT)
3815 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
3816 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3817 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
3818 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3819 span, gfc_index_one_node);
3820 gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
3822 gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
3823 gfc_index_one_node);
3825 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3826 gfc_conv_descriptor_lbound_get (dest,
3828 gfc_conv_descriptor_stride_get (dest,
3830 gfc_add_modify (&block, tmp2, tmp);
3831 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3832 gfc_conv_descriptor_offset_set (&block, dest, tmp);
3835 if (expr->expr_type == EXPR_FUNCTION
3836 && expr->value.function.isym
3837 && expr->value.function.isym->conversion
3838 && expr->value.function.actual->expr
3839 && expr->value.function.actual->expr->expr_type
3842 /* If a conversion expression has a null data pointer
3843 argument, nullify the allocatable component. */
3847 s = expr->value.function.actual->expr->symtree->n.sym;
3848 if (s->attr.allocatable || s->attr.pointer)
3850 non_null_expr = gfc_finish_block (&block);
3851 gfc_start_block (&block);
3852 gfc_conv_descriptor_data_set (&block, dest,
3854 null_expr = gfc_finish_block (&block);
3855 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
3856 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
3857 fold_convert (TREE_TYPE (tmp),
3858 null_pointer_node));
3859 return build3_v (COND_EXPR, tmp, null_expr,
3866 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3867 gfc_add_expr_to_block (&block, tmp);
3870 else if (expr->ts.type == BT_DERIVED)
3872 if (expr->expr_type != EXPR_STRUCTURE)
3874 gfc_init_se (&se, NULL);
3875 gfc_conv_expr (&se, expr);
3876 gfc_add_block_to_block (&block, &se.pre);
3877 gfc_add_modify (&block, dest,
3878 fold_convert (TREE_TYPE (dest), se.expr));
3879 gfc_add_block_to_block (&block, &se.post);
3883 /* Nested constructors. */
3884 tmp = gfc_trans_structure_assign (dest, expr);
3885 gfc_add_expr_to_block (&block, tmp);
3890 /* Scalar component. */
3891 gfc_init_se (&se, NULL);
3892 gfc_init_se (&lse, NULL);
3894 gfc_conv_expr (&se, expr);
3895 if (cm->ts.type == BT_CHARACTER)
3896 lse.string_length = cm->ts.u.cl->backend_decl;
3898 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3899 gfc_add_expr_to_block (&block, tmp);
3901 return gfc_finish_block (&block);
3904 /* Assign a derived type constructor to a variable. */
3907 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3915 gfc_start_block (&block);
3916 cm = expr->ts.u.derived->components;
3917 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3919 /* Skip absent members in default initializers. */
3923 field = cm->backend_decl;
3924 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3925 dest, field, NULL_TREE);
3926 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3927 gfc_add_expr_to_block (&block, tmp);
3929 return gfc_finish_block (&block);
3932 /* Build an expression for a constructor. If init is nonzero then
3933 this is part of a static variable initializer. */
3936 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3943 VEC(constructor_elt,gc) *v = NULL;
3945 gcc_assert (se->ss == NULL);
3946 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3947 type = gfc_typenode_for_spec (&expr->ts);
3951 /* Create a temporary variable and fill it in. */
3952 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
3953 tmp = gfc_trans_structure_assign (se->expr, expr);
3954 gfc_add_expr_to_block (&se->pre, tmp);
3958 cm = expr->ts.u.derived->components;
3960 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3962 /* Skip absent members in default initializers and allocatable
3963 components. Although the latter have a default initializer
3964 of EXPR_NULL,... by default, the static nullify is not needed
3965 since this is done every time we come into scope. */
3966 if (!c->expr || cm->attr.allocatable)
3969 val = gfc_conv_initializer (c->expr, &cm->ts,
3970 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
3971 cm->attr.pointer || cm->attr.proc_pointer);
3973 /* Append it to the constructor list. */
3974 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3976 se->expr = build_constructor (type, v);
3978 TREE_CONSTANT (se->expr) = 1;
3982 /* Translate a substring expression. */
3985 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3991 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3993 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3994 expr->value.character.length,
3995 expr->value.character.string);
3997 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3998 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4001 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4005 /* Entry point for expression translation. Evaluates a scalar quantity.
4006 EXPR is the expression to be translated, and SE is the state structure if
4007 called from within the scalarized. */
4010 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4012 if (se->ss && se->ss->expr == expr
4013 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4015 /* Substitute a scalar expression evaluated outside the scalarization
4017 se->expr = se->ss->data.scalar.expr;
4018 se->string_length = se->ss->string_length;
4019 gfc_advance_se_ss_chain (se);
4023 /* We need to convert the expressions for the iso_c_binding derived types.
4024 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4025 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4026 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4027 updated to be an integer with a kind equal to the size of a (void *). */
4028 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4029 && expr->ts.u.derived->attr.is_iso_c)
4031 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4032 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4034 /* Set expr_type to EXPR_NULL, which will result in
4035 null_pointer_node being used below. */
4036 expr->expr_type = EXPR_NULL;
4040 /* Update the type/kind of the expression to be what the new
4041 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4042 expr->ts.type = expr->ts.u.derived->ts.type;
4043 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4044 expr->ts.kind = expr->ts.u.derived->ts.kind;
4048 switch (expr->expr_type)
4051 gfc_conv_expr_op (se, expr);
4055 gfc_conv_function_expr (se, expr);
4059 gfc_conv_constant (se, expr);
4063 gfc_conv_variable (se, expr);
4067 se->expr = null_pointer_node;
4070 case EXPR_SUBSTRING:
4071 gfc_conv_substring_expr (se, expr);
4074 case EXPR_STRUCTURE:
4075 gfc_conv_structure (se, expr, 0);
4079 gfc_conv_array_constructor_expr (se, expr);
4088 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4089 of an assignment. */
4091 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4093 gfc_conv_expr (se, expr);
4094 /* All numeric lvalues should have empty post chains. If not we need to
4095 figure out a way of rewriting an lvalue so that it has no post chain. */
4096 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4099 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4100 numeric expressions. Used for scalar values where inserting cleanup code
4103 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4107 gcc_assert (expr->ts.type != BT_CHARACTER);
4108 gfc_conv_expr (se, expr);
4111 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4112 gfc_add_modify (&se->pre, val, se->expr);
4114 gfc_add_block_to_block (&se->pre, &se->post);
4118 /* Helper to translate an expression and convert it to a particular type. */
4120 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4122 gfc_conv_expr_val (se, expr);
4123 se->expr = convert (type, se->expr);
4127 /* Converts an expression so that it can be passed by reference. Scalar
4131 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4135 if (se->ss && se->ss->expr == expr
4136 && se->ss->type == GFC_SS_REFERENCE)
4138 se->expr = se->ss->data.scalar.expr;
4139 se->string_length = se->ss->string_length;
4140 gfc_advance_se_ss_chain (se);
4144 if (expr->ts.type == BT_CHARACTER)
4146 gfc_conv_expr (se, expr);
4147 gfc_conv_string_parameter (se);
4151 if (expr->expr_type == EXPR_VARIABLE)
4153 se->want_pointer = 1;
4154 gfc_conv_expr (se, expr);
4157 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4158 gfc_add_modify (&se->pre, var, se->expr);
4159 gfc_add_block_to_block (&se->pre, &se->post);
4165 if (expr->expr_type == EXPR_FUNCTION
4166 && expr->symtree->n.sym->attr.pointer
4167 && !expr->symtree->n.sym->attr.dimension)
4169 se->want_pointer = 1;
4170 gfc_conv_expr (se, expr);
4171 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4172 gfc_add_modify (&se->pre, var, se->expr);
4178 gfc_conv_expr (se, expr);
4180 /* Create a temporary var to hold the value. */
4181 if (TREE_CONSTANT (se->expr))
4183 tree tmp = se->expr;
4184 STRIP_TYPE_NOPS (tmp);
4185 var = build_decl (input_location,
4186 CONST_DECL, NULL, TREE_TYPE (tmp));
4187 DECL_INITIAL (var) = tmp;
4188 TREE_STATIC (var) = 1;
4193 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4194 gfc_add_modify (&se->pre, var, se->expr);
4196 gfc_add_block_to_block (&se->pre, &se->post);
4198 /* Take the address of that value. */
4199 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4204 gfc_trans_pointer_assign (gfc_code * code)
4206 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4210 /* Generate code for a pointer assignment. */
4213 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4224 gfc_start_block (&block);
4226 gfc_init_se (&lse, NULL);
4228 lss = gfc_walk_expr (expr1);
4229 rss = gfc_walk_expr (expr2);
4230 if (lss == gfc_ss_terminator)
4232 /* Scalar pointers. */
4233 lse.want_pointer = 1;
4234 gfc_conv_expr (&lse, expr1);
4235 gcc_assert (rss == gfc_ss_terminator);
4236 gfc_init_se (&rse, NULL);
4237 rse.want_pointer = 1;
4238 gfc_conv_expr (&rse, expr2);
4240 if (expr1->symtree->n.sym->attr.proc_pointer
4241 && expr1->symtree->n.sym->attr.dummy)
4242 lse.expr = build_fold_indirect_ref_loc (input_location,
4245 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4246 && expr2->symtree->n.sym->attr.dummy)
4247 rse.expr = build_fold_indirect_ref_loc (input_location,
4250 gfc_add_block_to_block (&block, &lse.pre);
4251 gfc_add_block_to_block (&block, &rse.pre);
4253 /* Check character lengths if character expression. The test is only
4254 really added if -fbounds-check is enabled. */
4255 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4256 && !expr1->symtree->n.sym->attr.proc_pointer
4257 && !gfc_is_proc_ptr_comp (expr1, NULL))
4259 gcc_assert (expr2->ts.type == BT_CHARACTER);
4260 gcc_assert (lse.string_length && rse.string_length);
4261 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4262 lse.string_length, rse.string_length,
4266 gfc_add_modify (&block, lse.expr,
4267 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4269 gfc_add_block_to_block (&block, &rse.post);
4270 gfc_add_block_to_block (&block, &lse.post);
4275 tree strlen_rhs = NULL_TREE;
4277 /* Array pointer. */
4278 gfc_conv_expr_descriptor (&lse, expr1, lss);
4279 strlen_lhs = lse.string_length;
4280 switch (expr2->expr_type)
4283 /* Just set the data pointer to null. */
4284 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4288 /* Assign directly to the pointer's descriptor. */
4289 lse.direct_byref = 1;
4290 gfc_conv_expr_descriptor (&lse, expr2, rss);
4291 strlen_rhs = lse.string_length;
4293 /* If this is a subreference array pointer assignment, use the rhs
4294 descriptor element size for the lhs span. */
4295 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4297 decl = expr1->symtree->n.sym->backend_decl;
4298 gfc_init_se (&rse, NULL);
4299 rse.descriptor_only = 1;
4300 gfc_conv_expr (&rse, expr2);
4301 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4302 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4303 if (!INTEGER_CST_P (tmp))
4304 gfc_add_block_to_block (&lse.post, &rse.pre);
4305 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4311 /* Assign to a temporary descriptor and then copy that
4312 temporary to the pointer. */
4314 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4317 lse.direct_byref = 1;
4318 gfc_conv_expr_descriptor (&lse, expr2, rss);
4319 strlen_rhs = lse.string_length;
4320 gfc_add_modify (&lse.pre, desc, tmp);
4324 gfc_add_block_to_block (&block, &lse.pre);
4326 /* Check string lengths if applicable. The check is only really added
4327 to the output code if -fbounds-check is enabled. */
4328 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4330 gcc_assert (expr2->ts.type == BT_CHARACTER);
4331 gcc_assert (strlen_lhs && strlen_rhs);
4332 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4333 strlen_lhs, strlen_rhs, &block);
4336 gfc_add_block_to_block (&block, &lse.post);
4338 return gfc_finish_block (&block);
4342 /* Makes sure se is suitable for passing as a function string parameter. */
4343 /* TODO: Need to check all callers of this function. It may be abused. */
4346 gfc_conv_string_parameter (gfc_se * se)
4350 if (TREE_CODE (se->expr) == STRING_CST)
4352 type = TREE_TYPE (TREE_TYPE (se->expr));
4353 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4357 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4359 if (TREE_CODE (se->expr) != INDIRECT_REF)
4361 type = TREE_TYPE (se->expr);
4362 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4366 type = gfc_get_character_type_len (gfc_default_character_kind,
4368 type = build_pointer_type (type);
4369 se->expr = gfc_build_addr_expr (type, se->expr);
4373 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4374 gcc_assert (se->string_length
4375 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4379 /* Generate code for assignment of scalar variables. Includes character
4380 strings and derived types with allocatable components. */
4383 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4384 bool l_is_temp, bool r_is_var)
4390 gfc_init_block (&block);
4392 if (ts.type == BT_CHARACTER)
4397 if (lse->string_length != NULL_TREE)
4399 gfc_conv_string_parameter (lse);
4400 gfc_add_block_to_block (&block, &lse->pre);
4401 llen = lse->string_length;
4404 if (rse->string_length != NULL_TREE)
4406 gcc_assert (rse->string_length != NULL_TREE);
4407 gfc_conv_string_parameter (rse);
4408 gfc_add_block_to_block (&block, &rse->pre);
4409 rlen = rse->string_length;
4412 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4413 rse->expr, ts.kind);
4415 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4419 /* Are the rhs and the lhs the same? */
4422 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4423 gfc_build_addr_expr (NULL_TREE, lse->expr),
4424 gfc_build_addr_expr (NULL_TREE, rse->expr));
4425 cond = gfc_evaluate_now (cond, &lse->pre);
4428 /* Deallocate the lhs allocated components as long as it is not
4429 the same as the rhs. This must be done following the assignment
4430 to prevent deallocating data that could be used in the rhs
4434 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4435 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4437 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4439 gfc_add_expr_to_block (&lse->post, tmp);
4442 gfc_add_block_to_block (&block, &rse->pre);
4443 gfc_add_block_to_block (&block, &lse->pre);
4445 gfc_add_modify (&block, lse->expr,
4446 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4448 /* Do a deep copy if the rhs is a variable, if it is not the
4452 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4453 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4455 gfc_add_expr_to_block (&block, tmp);
4458 else if (ts.type == BT_DERIVED)
4460 gfc_add_block_to_block (&block, &lse->pre);
4461 gfc_add_block_to_block (&block, &rse->pre);
4462 tmp = gfc_evaluate_now (rse->expr, &block);
4463 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp);
4464 gfc_add_modify (&block, lse->expr, tmp);
4468 gfc_add_block_to_block (&block, &lse->pre);
4469 gfc_add_block_to_block (&block, &rse->pre);
4471 gfc_add_modify (&block, lse->expr,
4472 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4475 gfc_add_block_to_block (&block, &lse->post);
4476 gfc_add_block_to_block (&block, &rse->post);
4478 return gfc_finish_block (&block);
4482 /* Try to translate array(:) = func (...), where func is a transformational
4483 array function, without using a temporary. Returns NULL is this isn't the
4487 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4492 bool seen_array_ref;
4494 gfc_component *comp = NULL;
4496 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4497 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4500 /* Elemental functions don't need a temporary anyway. */
4501 if (expr2->value.function.esym != NULL
4502 && expr2->value.function.esym->attr.elemental)
4505 /* Fail if rhs is not FULL or a contiguous section. */
4506 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4509 /* Fail if EXPR1 can't be expressed as a descriptor. */
4510 if (gfc_ref_needs_temporary_p (expr1->ref))
4513 /* Functions returning pointers need temporaries. */
4514 if (expr2->symtree->n.sym->attr.pointer
4515 || expr2->symtree->n.sym->attr.allocatable)
4518 /* Character array functions need temporaries unless the
4519 character lengths are the same. */
4520 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4522 if (expr1->ts.u.cl->length == NULL
4523 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4526 if (expr2->ts.u.cl->length == NULL
4527 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4530 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4531 expr2->ts.u.cl->length->value.integer) != 0)
4535 /* Check that no LHS component references appear during an array
4536 reference. This is needed because we do not have the means to
4537 span any arbitrary stride with an array descriptor. This check
4538 is not needed for the rhs because the function result has to be
4540 seen_array_ref = false;
4541 for (ref = expr1->ref; ref; ref = ref->next)
4543 if (ref->type == REF_ARRAY)
4544 seen_array_ref= true;
4545 else if (ref->type == REF_COMPONENT && seen_array_ref)
4549 /* Check for a dependency. */
4550 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4551 expr2->value.function.esym,
4552 expr2->value.function.actual,
4556 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4558 gcc_assert (expr2->value.function.isym
4559 || (gfc_is_proc_ptr_comp (expr2, &comp)
4560 && comp && comp->attr.dimension)
4561 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
4562 && expr2->value.function.esym->result->attr.dimension));
4564 ss = gfc_walk_expr (expr1);
4565 gcc_assert (ss != gfc_ss_terminator);
4566 gfc_init_se (&se, NULL);
4567 gfc_start_block (&se.pre);
4568 se.want_pointer = 1;
4570 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
4572 se.direct_byref = 1;
4573 se.ss = gfc_walk_expr (expr2);
4574 gcc_assert (se.ss != gfc_ss_terminator);
4575 gfc_conv_function_expr (&se, expr2);
4576 gfc_add_block_to_block (&se.pre, &se.post);
4578 return gfc_finish_block (&se.pre);
4581 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4584 is_zero_initializer_p (gfc_expr * expr)
4586 if (expr->expr_type != EXPR_CONSTANT)
4589 /* We ignore constants with prescribed memory representations for now. */
4590 if (expr->representation.string)
4593 switch (expr->ts.type)
4596 return mpz_cmp_si (expr->value.integer, 0) == 0;
4599 return mpfr_zero_p (expr->value.real)
4600 && MPFR_SIGN (expr->value.real) >= 0;
4603 return expr->value.logical == 0;
4606 return mpfr_zero_p (mpc_realref (expr->value.complex))
4607 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4608 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4609 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4617 /* Try to efficiently translate array(:) = 0. Return NULL if this
4621 gfc_trans_zero_assign (gfc_expr * expr)
4623 tree dest, len, type;
4627 sym = expr->symtree->n.sym;
4628 dest = gfc_get_symbol_decl (sym);
4630 type = TREE_TYPE (dest);
4631 if (POINTER_TYPE_P (type))
4632 type = TREE_TYPE (type);
4633 if (!GFC_ARRAY_TYPE_P (type))
4636 /* Determine the length of the array. */
4637 len = GFC_TYPE_ARRAY_SIZE (type);
4638 if (!len || TREE_CODE (len) != INTEGER_CST)
4641 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4642 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4643 fold_convert (gfc_array_index_type, tmp));
4645 /* If we are zeroing a local array avoid taking its address by emitting
4647 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4648 return build2 (MODIFY_EXPR, void_type_node,
4649 dest, build_constructor (TREE_TYPE (dest), NULL));
4651 /* Convert arguments to the correct types. */
4652 dest = fold_convert (pvoid_type_node, dest);
4653 len = fold_convert (size_type_node, len);
4655 /* Construct call to __builtin_memset. */
4656 tmp = build_call_expr_loc (input_location,
4657 built_in_decls[BUILT_IN_MEMSET],
4658 3, dest, integer_zero_node, len);
4659 return fold_convert (void_type_node, tmp);
4663 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4664 that constructs the call to __builtin_memcpy. */
4667 gfc_build_memcpy_call (tree dst, tree src, tree len)
4671 /* Convert arguments to the correct types. */
4672 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4673 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4675 dst = fold_convert (pvoid_type_node, dst);
4677 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4678 src = gfc_build_addr_expr (pvoid_type_node, src);
4680 src = fold_convert (pvoid_type_node, src);
4682 len = fold_convert (size_type_node, len);
4684 /* Construct call to __builtin_memcpy. */
4685 tmp = build_call_expr_loc (input_location,
4686 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4687 return fold_convert (void_type_node, tmp);
4691 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4692 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4693 source/rhs, both are gfc_full_array_ref_p which have been checked for
4697 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4699 tree dst, dlen, dtype;
4700 tree src, slen, stype;
4703 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4704 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4706 dtype = TREE_TYPE (dst);
4707 if (POINTER_TYPE_P (dtype))
4708 dtype = TREE_TYPE (dtype);
4709 stype = TREE_TYPE (src);
4710 if (POINTER_TYPE_P (stype))
4711 stype = TREE_TYPE (stype);
4713 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4716 /* Determine the lengths of the arrays. */
4717 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4718 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4720 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4721 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4722 fold_convert (gfc_array_index_type, tmp));
4724 slen = GFC_TYPE_ARRAY_SIZE (stype);
4725 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4727 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4728 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4729 fold_convert (gfc_array_index_type, tmp));
4731 /* Sanity check that they are the same. This should always be
4732 the case, as we should already have checked for conformance. */
4733 if (!tree_int_cst_equal (slen, dlen))
4736 return gfc_build_memcpy_call (dst, src, dlen);
4740 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4741 this can't be done. EXPR1 is the destination/lhs for which
4742 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4745 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4747 unsigned HOST_WIDE_INT nelem;
4753 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4757 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4758 dtype = TREE_TYPE (dst);
4759 if (POINTER_TYPE_P (dtype))
4760 dtype = TREE_TYPE (dtype);
4761 if (!GFC_ARRAY_TYPE_P (dtype))
4764 /* Determine the lengths of the array. */
4765 len = GFC_TYPE_ARRAY_SIZE (dtype);
4766 if (!len || TREE_CODE (len) != INTEGER_CST)
4769 /* Confirm that the constructor is the same size. */
4770 if (compare_tree_int (len, nelem) != 0)
4773 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4774 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4775 fold_convert (gfc_array_index_type, tmp));
4777 stype = gfc_typenode_for_spec (&expr2->ts);
4778 src = gfc_build_constant_array_constructor (expr2, stype);
4780 stype = TREE_TYPE (src);
4781 if (POINTER_TYPE_P (stype))
4782 stype = TREE_TYPE (stype);
4784 return gfc_build_memcpy_call (dst, src, len);
4788 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4789 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
4792 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4797 gfc_ss *lss_section;
4804 bool scalar_to_array;
4807 /* Assignment of the form lhs = rhs. */
4808 gfc_start_block (&block);
4810 gfc_init_se (&lse, NULL);
4811 gfc_init_se (&rse, NULL);
4814 lss = gfc_walk_expr (expr1);
4816 if (lss != gfc_ss_terminator)
4818 /* Allow the scalarizer to workshare array assignments. */
4819 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4820 ompws_flags |= OMPWS_SCALARIZER_WS;
4822 /* The assignment needs scalarization. */
4825 /* Find a non-scalar SS from the lhs. */
4826 while (lss_section != gfc_ss_terminator
4827 && lss_section->type != GFC_SS_SECTION)
4828 lss_section = lss_section->next;
4830 gcc_assert (lss_section != gfc_ss_terminator);
4832 /* Initialize the scalarizer. */
4833 gfc_init_loopinfo (&loop);
4836 rss = gfc_walk_expr (expr2);
4837 if (rss == gfc_ss_terminator)
4839 /* The rhs is scalar. Add a ss for the expression. */
4840 rss = gfc_get_ss ();
4841 rss->next = gfc_ss_terminator;
4842 rss->type = GFC_SS_SCALAR;
4845 /* Associate the SS with the loop. */
4846 gfc_add_ss_to_loop (&loop, lss);
4847 gfc_add_ss_to_loop (&loop, rss);
4849 /* Calculate the bounds of the scalarization. */
4850 gfc_conv_ss_startstride (&loop);
4851 /* Resolve any data dependencies in the statement. */
4852 gfc_conv_resolve_dependencies (&loop, lss, rss);
4853 /* Setup the scalarizing loops. */
4854 gfc_conv_loop_setup (&loop, &expr2->where);
4856 /* Setup the gfc_se structures. */
4857 gfc_copy_loopinfo_to_se (&lse, &loop);
4858 gfc_copy_loopinfo_to_se (&rse, &loop);
4861 gfc_mark_ss_chain_used (rss, 1);
4862 if (loop.temp_ss == NULL)
4865 gfc_mark_ss_chain_used (lss, 1);
4869 lse.ss = loop.temp_ss;
4870 gfc_mark_ss_chain_used (lss, 3);
4871 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4874 /* Start the scalarized loop body. */
4875 gfc_start_scalarized_body (&loop, &body);
4878 gfc_init_block (&body);
4880 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4882 /* Translate the expression. */
4883 gfc_conv_expr (&rse, expr2);
4885 /* Stabilize a string length for temporaries. */
4886 if (expr2->ts.type == BT_CHARACTER)
4887 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
4889 string_length = NULL_TREE;
4893 gfc_conv_tmp_array_ref (&lse);
4894 gfc_advance_se_ss_chain (&lse);
4895 if (expr2->ts.type == BT_CHARACTER)
4896 lse.string_length = string_length;
4899 gfc_conv_expr (&lse, expr1);
4901 /* Assignments of scalar derived types with allocatable components
4902 to arrays must be done with a deep copy and the rhs temporary
4903 must have its components deallocated afterwards. */
4904 scalar_to_array = (expr2->ts.type == BT_DERIVED
4905 && expr2->ts.u.derived->attr.alloc_comp
4906 && expr2->expr_type != EXPR_VARIABLE
4907 && !gfc_is_constant_expr (expr2)
4908 && expr1->rank && !expr2->rank);
4909 if (scalar_to_array)
4911 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
4912 gfc_add_expr_to_block (&loop.post, tmp);
4915 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4916 l_is_temp || init_flag,
4917 (expr2->expr_type == EXPR_VARIABLE)
4918 || scalar_to_array);
4919 gfc_add_expr_to_block (&body, tmp);
4921 if (lss == gfc_ss_terminator)
4923 /* Use the scalar assignment as is. */
4924 gfc_add_block_to_block (&block, &body);
4928 gcc_assert (lse.ss == gfc_ss_terminator
4929 && rse.ss == gfc_ss_terminator);
4933 gfc_trans_scalarized_loop_boundary (&loop, &body);
4935 /* We need to copy the temporary to the actual lhs. */
4936 gfc_init_se (&lse, NULL);
4937 gfc_init_se (&rse, NULL);
4938 gfc_copy_loopinfo_to_se (&lse, &loop);
4939 gfc_copy_loopinfo_to_se (&rse, &loop);
4941 rse.ss = loop.temp_ss;
4944 gfc_conv_tmp_array_ref (&rse);
4945 gfc_advance_se_ss_chain (&rse);
4946 gfc_conv_expr (&lse, expr1);
4948 gcc_assert (lse.ss == gfc_ss_terminator
4949 && rse.ss == gfc_ss_terminator);
4951 if (expr2->ts.type == BT_CHARACTER)
4952 rse.string_length = string_length;
4954 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4956 gfc_add_expr_to_block (&body, tmp);
4959 /* Generate the copying loops. */
4960 gfc_trans_scalarizing_loops (&loop, &body);
4962 /* Wrap the whole thing up. */
4963 gfc_add_block_to_block (&block, &loop.pre);
4964 gfc_add_block_to_block (&block, &loop.post);
4966 gfc_cleanup_loop (&loop);
4969 return gfc_finish_block (&block);
4973 /* Check whether EXPR is a copyable array. */
4976 copyable_array_p (gfc_expr * expr)
4978 if (expr->expr_type != EXPR_VARIABLE)
4981 /* First check it's an array. */
4982 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4985 if (!gfc_full_array_ref_p (expr->ref, NULL))
4988 /* Next check that it's of a simple enough type. */
4989 switch (expr->ts.type)
5001 return !expr->ts.u.derived->attr.alloc_comp;
5010 /* Translate an assignment. */
5013 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5017 /* Special case a single function returning an array. */
5018 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5020 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5025 /* Special case assigning an array to zero. */
5026 if (copyable_array_p (expr1)
5027 && is_zero_initializer_p (expr2))
5029 tmp = gfc_trans_zero_assign (expr1);
5034 /* Special case copying one array to another. */
5035 if (copyable_array_p (expr1)
5036 && copyable_array_p (expr2)
5037 && gfc_compare_types (&expr1->ts, &expr2->ts)
5038 && !gfc_check_dependency (expr1, expr2, 0))
5040 tmp = gfc_trans_array_copy (expr1, expr2);
5045 /* Special case initializing an array from a constant array constructor. */
5046 if (copyable_array_p (expr1)
5047 && expr2->expr_type == EXPR_ARRAY
5048 && gfc_compare_types (&expr1->ts, &expr2->ts))
5050 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5055 /* Fallback to the scalarizer to generate explicit loops. */
5056 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
5060 gfc_trans_init_assign (gfc_code * code)
5062 return gfc_trans_assignment (code->expr1, code->expr2, true);
5066 gfc_trans_assign (gfc_code * code)
5068 return gfc_trans_assignment (code->expr1, code->expr2, false);