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)
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)
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 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1510 if (gfc_is_proc_ptr_comp (expr, NULL))
1511 tmp = gfc_get_proc_ptr_comp (se, expr);
1512 else if (sym->attr.dummy)
1514 tmp = gfc_get_symbol_decl (sym);
1515 if (sym->attr.proc_pointer)
1516 tmp = build_fold_indirect_ref_loc (input_location,
1518 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1519 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1523 if (!sym->backend_decl)
1524 sym->backend_decl = gfc_get_extern_function_decl (sym);
1526 tmp = sym->backend_decl;
1528 if (sym->attr.cray_pointee)
1530 /* TODO - make the cray pointee a pointer to a procedure,
1531 assign the pointer to it and use it for the call. This
1533 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1534 gfc_get_symbol_decl (sym->cp_pointer));
1535 tmp = gfc_evaluate_now (tmp, &se->pre);
1538 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1540 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1541 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1548 /* Initialize MAPPING. */
1551 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1553 mapping->syms = NULL;
1554 mapping->charlens = NULL;
1558 /* Free all memory held by MAPPING (but not MAPPING itself). */
1561 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1563 gfc_interface_sym_mapping *sym;
1564 gfc_interface_sym_mapping *nextsym;
1566 gfc_charlen *nextcl;
1568 for (sym = mapping->syms; sym; sym = nextsym)
1570 nextsym = sym->next;
1571 sym->new_sym->n.sym->formal = NULL;
1572 gfc_free_symbol (sym->new_sym->n.sym);
1573 gfc_free_expr (sym->expr);
1574 gfc_free (sym->new_sym);
1577 for (cl = mapping->charlens; cl; cl = nextcl)
1580 gfc_free_expr (cl->length);
1586 /* Return a copy of gfc_charlen CL. Add the returned structure to
1587 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1589 static gfc_charlen *
1590 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1593 gfc_charlen *new_charlen;
1595 new_charlen = gfc_get_charlen ();
1596 new_charlen->next = mapping->charlens;
1597 new_charlen->length = gfc_copy_expr (cl->length);
1599 mapping->charlens = new_charlen;
1604 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1605 array variable that can be used as the actual argument for dummy
1606 argument SYM. Add any initialization code to BLOCK. PACKED is as
1607 for gfc_get_nodesc_array_type and DATA points to the first element
1608 in the passed array. */
1611 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1612 gfc_packed packed, tree data)
1617 type = gfc_typenode_for_spec (&sym->ts);
1618 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1619 !sym->attr.target && !sym->attr.pointer
1620 && !sym->attr.proc_pointer);
1622 var = gfc_create_var (type, "ifm");
1623 gfc_add_modify (block, var, fold_convert (type, data));
1629 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1630 and offset of descriptorless array type TYPE given that it has the same
1631 size as DESC. Add any set-up code to BLOCK. */
1634 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1641 offset = gfc_index_zero_node;
1642 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1644 dim = gfc_rank_cst[n];
1645 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1646 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1648 GFC_TYPE_ARRAY_LBOUND (type, n)
1649 = gfc_conv_descriptor_lbound_get (desc, dim);
1650 GFC_TYPE_ARRAY_UBOUND (type, n)
1651 = gfc_conv_descriptor_ubound_get (desc, dim);
1653 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1655 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1656 gfc_conv_descriptor_ubound_get (desc, dim),
1657 gfc_conv_descriptor_lbound_get (desc, dim));
1658 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1659 GFC_TYPE_ARRAY_LBOUND (type, n),
1661 tmp = gfc_evaluate_now (tmp, block);
1662 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1664 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1665 GFC_TYPE_ARRAY_LBOUND (type, n),
1666 GFC_TYPE_ARRAY_STRIDE (type, n));
1667 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1669 offset = gfc_evaluate_now (offset, block);
1670 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1674 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1675 in SE. The caller may still use se->expr and se->string_length after
1676 calling this function. */
1679 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1680 gfc_symbol * sym, gfc_se * se,
1683 gfc_interface_sym_mapping *sm;
1687 gfc_symbol *new_sym;
1689 gfc_symtree *new_symtree;
1691 /* Create a new symbol to represent the actual argument. */
1692 new_sym = gfc_new_symbol (sym->name, NULL);
1693 new_sym->ts = sym->ts;
1694 new_sym->as = gfc_copy_array_spec (sym->as);
1695 new_sym->attr.referenced = 1;
1696 new_sym->attr.dimension = sym->attr.dimension;
1697 new_sym->attr.pointer = sym->attr.pointer;
1698 new_sym->attr.allocatable = sym->attr.allocatable;
1699 new_sym->attr.flavor = sym->attr.flavor;
1700 new_sym->attr.function = sym->attr.function;
1702 /* Ensure that the interface is available and that
1703 descriptors are passed for array actual arguments. */
1704 if (sym->attr.flavor == FL_PROCEDURE)
1706 new_sym->formal = expr->symtree->n.sym->formal;
1707 new_sym->attr.always_explicit
1708 = expr->symtree->n.sym->attr.always_explicit;
1711 /* Create a fake symtree for it. */
1713 new_symtree = gfc_new_symtree (&root, sym->name);
1714 new_symtree->n.sym = new_sym;
1715 gcc_assert (new_symtree == root);
1717 /* Create a dummy->actual mapping. */
1718 sm = XCNEW (gfc_interface_sym_mapping);
1719 sm->next = mapping->syms;
1721 sm->new_sym = new_symtree;
1722 sm->expr = gfc_copy_expr (expr);
1725 /* Stabilize the argument's value. */
1726 if (!sym->attr.function && se)
1727 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1729 if (sym->ts.type == BT_CHARACTER)
1731 /* Create a copy of the dummy argument's length. */
1732 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1733 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1735 /* If the length is specified as "*", record the length that
1736 the caller is passing. We should use the callee's length
1737 in all other cases. */
1738 if (!new_sym->ts.u.cl->length && se)
1740 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1741 new_sym->ts.u.cl->backend_decl = se->string_length;
1748 /* Use the passed value as-is if the argument is a function. */
1749 if (sym->attr.flavor == FL_PROCEDURE)
1752 /* If the argument is either a string or a pointer to a string,
1753 convert it to a boundless character type. */
1754 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1756 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1757 tmp = build_pointer_type (tmp);
1758 if (sym->attr.pointer)
1759 value = build_fold_indirect_ref_loc (input_location,
1763 value = fold_convert (tmp, value);
1766 /* If the argument is a scalar, a pointer to an array or an allocatable,
1768 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1769 value = build_fold_indirect_ref_loc (input_location,
1772 /* For character(*), use the actual argument's descriptor. */
1773 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1774 value = build_fold_indirect_ref_loc (input_location,
1777 /* If the argument is an array descriptor, use it to determine
1778 information about the actual argument's shape. */
1779 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1780 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1782 /* Get the actual argument's descriptor. */
1783 desc = build_fold_indirect_ref_loc (input_location,
1786 /* Create the replacement variable. */
1787 tmp = gfc_conv_descriptor_data_get (desc);
1788 value = gfc_get_interface_mapping_array (&se->pre, sym,
1791 /* Use DESC to work out the upper bounds, strides and offset. */
1792 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1795 /* Otherwise we have a packed array. */
1796 value = gfc_get_interface_mapping_array (&se->pre, sym,
1797 PACKED_FULL, se->expr);
1799 new_sym->backend_decl = value;
1803 /* Called once all dummy argument mappings have been added to MAPPING,
1804 but before the mapping is used to evaluate expressions. Pre-evaluate
1805 the length of each argument, adding any initialization code to PRE and
1806 any finalization code to POST. */
1809 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1810 stmtblock_t * pre, stmtblock_t * post)
1812 gfc_interface_sym_mapping *sym;
1816 for (sym = mapping->syms; sym; sym = sym->next)
1817 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1818 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1820 expr = sym->new_sym->n.sym->ts.u.cl->length;
1821 gfc_apply_interface_mapping_to_expr (mapping, expr);
1822 gfc_init_se (&se, NULL);
1823 gfc_conv_expr (&se, expr);
1824 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1825 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1826 gfc_add_block_to_block (pre, &se.pre);
1827 gfc_add_block_to_block (post, &se.post);
1829 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1834 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1838 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1839 gfc_constructor * c)
1841 for (; c; c = c->next)
1843 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1846 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1847 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1848 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1854 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1858 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1863 for (; ref; ref = ref->next)
1867 for (n = 0; n < ref->u.ar.dimen; n++)
1869 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1870 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1871 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1873 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1880 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1881 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1887 /* Convert intrinsic function calls into result expressions. */
1890 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1898 arg1 = expr->value.function.actual->expr;
1899 if (expr->value.function.actual->next)
1900 arg2 = expr->value.function.actual->next->expr;
1904 sym = arg1->symtree->n.sym;
1906 if (sym->attr.dummy)
1911 switch (expr->value.function.isym->id)
1914 /* TODO figure out why this condition is necessary. */
1915 if (sym->attr.function
1916 && (arg1->ts.u.cl->length == NULL
1917 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
1918 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
1921 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
1928 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1930 dup = mpz_get_si (arg2->value.integer);
1935 dup = sym->as->rank;
1939 for (; d < dup; d++)
1943 if (!sym->as->upper[d] || !sym->as->lower[d])
1945 gfc_free_expr (new_expr);
1949 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1950 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1952 new_expr = gfc_multiply (new_expr, tmp);
1958 case GFC_ISYM_LBOUND:
1959 case GFC_ISYM_UBOUND:
1960 /* TODO These implementations of lbound and ubound do not limit if
1961 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1966 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1967 d = mpz_get_si (arg2->value.integer) - 1;
1969 /* TODO: If the need arises, this could produce an array of
1973 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1975 if (sym->as->lower[d])
1976 new_expr = gfc_copy_expr (sym->as->lower[d]);
1980 if (sym->as->upper[d])
1981 new_expr = gfc_copy_expr (sym->as->upper[d]);
1989 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
1993 gfc_replace_expr (expr, new_expr);
1999 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2000 gfc_interface_mapping * mapping)
2002 gfc_formal_arglist *f;
2003 gfc_actual_arglist *actual;
2005 actual = expr->value.function.actual;
2006 f = map_expr->symtree->n.sym->formal;
2008 for (; f && actual; f = f->next, actual = actual->next)
2013 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2016 if (map_expr->symtree->n.sym->attr.dimension)
2021 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2023 for (d = 0; d < as->rank; d++)
2025 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2026 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2029 expr->value.function.esym->as = as;
2032 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2034 expr->value.function.esym->ts.u.cl->length
2035 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2037 gfc_apply_interface_mapping_to_expr (mapping,
2038 expr->value.function.esym->ts.u.cl->length);
2043 /* EXPR is a copy of an expression that appeared in the interface
2044 associated with MAPPING. Walk it recursively looking for references to
2045 dummy arguments that MAPPING maps to actual arguments. Replace each such
2046 reference with a reference to the associated actual argument. */
2049 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2052 gfc_interface_sym_mapping *sym;
2053 gfc_actual_arglist *actual;
2058 /* Copying an expression does not copy its length, so do that here. */
2059 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2061 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2062 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2065 /* Apply the mapping to any references. */
2066 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2068 /* ...and to the expression's symbol, if it has one. */
2069 /* TODO Find out why the condition on expr->symtree had to be moved into
2070 the loop rather than being outside it, as originally. */
2071 for (sym = mapping->syms; sym; sym = sym->next)
2072 if (expr->symtree && sym->old == expr->symtree->n.sym)
2074 if (sym->new_sym->n.sym->backend_decl)
2075 expr->symtree = sym->new_sym;
2077 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2080 /* ...and to subexpressions in expr->value. */
2081 switch (expr->expr_type)
2086 case EXPR_SUBSTRING:
2090 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2091 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2095 for (actual = expr->value.function.actual; actual; actual = actual->next)
2096 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2098 if (expr->value.function.esym == NULL
2099 && expr->value.function.isym != NULL
2100 && expr->value.function.actual->expr->symtree
2101 && gfc_map_intrinsic_function (expr, mapping))
2104 for (sym = mapping->syms; sym; sym = sym->next)
2105 if (sym->old == expr->value.function.esym)
2107 expr->value.function.esym = sym->new_sym->n.sym;
2108 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2109 expr->value.function.esym->result = sym->new_sym->n.sym;
2114 case EXPR_STRUCTURE:
2115 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2128 /* Evaluate interface expression EXPR using MAPPING. Store the result
2132 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2133 gfc_se * se, gfc_expr * expr)
2135 expr = gfc_copy_expr (expr);
2136 gfc_apply_interface_mapping_to_expr (mapping, expr);
2137 gfc_conv_expr (se, expr);
2138 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2139 gfc_free_expr (expr);
2143 /* Returns a reference to a temporary array into which a component of
2144 an actual argument derived type array is copied and then returned
2145 after the function call. */
2147 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2148 int g77, sym_intent intent)
2164 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2166 gfc_init_se (&lse, NULL);
2167 gfc_init_se (&rse, NULL);
2169 /* Walk the argument expression. */
2170 rss = gfc_walk_expr (expr);
2172 gcc_assert (rss != gfc_ss_terminator);
2174 /* Initialize the scalarizer. */
2175 gfc_init_loopinfo (&loop);
2176 gfc_add_ss_to_loop (&loop, rss);
2178 /* Calculate the bounds of the scalarization. */
2179 gfc_conv_ss_startstride (&loop);
2181 /* Build an ss for the temporary. */
2182 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2183 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2185 base_type = gfc_typenode_for_spec (&expr->ts);
2186 if (GFC_ARRAY_TYPE_P (base_type)
2187 || GFC_DESCRIPTOR_TYPE_P (base_type))
2188 base_type = gfc_get_element_type (base_type);
2190 loop.temp_ss = gfc_get_ss ();;
2191 loop.temp_ss->type = GFC_SS_TEMP;
2192 loop.temp_ss->data.temp.type = base_type;
2194 if (expr->ts.type == BT_CHARACTER)
2195 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2197 loop.temp_ss->string_length = NULL;
2199 parmse->string_length = loop.temp_ss->string_length;
2200 loop.temp_ss->data.temp.dimen = loop.dimen;
2201 loop.temp_ss->next = gfc_ss_terminator;
2203 /* Associate the SS with the loop. */
2204 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2206 /* Setup the scalarizing loops. */
2207 gfc_conv_loop_setup (&loop, &expr->where);
2209 /* Pass the temporary descriptor back to the caller. */
2210 info = &loop.temp_ss->data.info;
2211 parmse->expr = info->descriptor;
2213 /* Setup the gfc_se structures. */
2214 gfc_copy_loopinfo_to_se (&lse, &loop);
2215 gfc_copy_loopinfo_to_se (&rse, &loop);
2218 lse.ss = loop.temp_ss;
2219 gfc_mark_ss_chain_used (rss, 1);
2220 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2222 /* Start the scalarized loop body. */
2223 gfc_start_scalarized_body (&loop, &body);
2225 /* Translate the expression. */
2226 gfc_conv_expr (&rse, expr);
2228 gfc_conv_tmp_array_ref (&lse);
2229 gfc_advance_se_ss_chain (&lse);
2231 if (intent != INTENT_OUT)
2233 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2234 gfc_add_expr_to_block (&body, tmp);
2235 gcc_assert (rse.ss == gfc_ss_terminator);
2236 gfc_trans_scalarizing_loops (&loop, &body);
2240 /* Make sure that the temporary declaration survives by merging
2241 all the loop declarations into the current context. */
2242 for (n = 0; n < loop.dimen; n++)
2244 gfc_merge_block_scope (&body);
2245 body = loop.code[loop.order[n]];
2247 gfc_merge_block_scope (&body);
2250 /* Add the post block after the second loop, so that any
2251 freeing of allocated memory is done at the right time. */
2252 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2254 /**********Copy the temporary back again.*********/
2256 gfc_init_se (&lse, NULL);
2257 gfc_init_se (&rse, NULL);
2259 /* Walk the argument expression. */
2260 lss = gfc_walk_expr (expr);
2261 rse.ss = loop.temp_ss;
2264 /* Initialize the scalarizer. */
2265 gfc_init_loopinfo (&loop2);
2266 gfc_add_ss_to_loop (&loop2, lss);
2268 /* Calculate the bounds of the scalarization. */
2269 gfc_conv_ss_startstride (&loop2);
2271 /* Setup the scalarizing loops. */
2272 gfc_conv_loop_setup (&loop2, &expr->where);
2274 gfc_copy_loopinfo_to_se (&lse, &loop2);
2275 gfc_copy_loopinfo_to_se (&rse, &loop2);
2277 gfc_mark_ss_chain_used (lss, 1);
2278 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2280 /* Declare the variable to hold the temporary offset and start the
2281 scalarized loop body. */
2282 offset = gfc_create_var (gfc_array_index_type, NULL);
2283 gfc_start_scalarized_body (&loop2, &body);
2285 /* Build the offsets for the temporary from the loop variables. The
2286 temporary array has lbounds of zero and strides of one in all
2287 dimensions, so this is very simple. The offset is only computed
2288 outside the innermost loop, so the overall transfer could be
2289 optimized further. */
2290 info = &rse.ss->data.info;
2292 tmp_index = gfc_index_zero_node;
2293 for (n = info->dimen - 1; n > 0; n--)
2296 tmp = rse.loop->loopvar[n];
2297 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2298 tmp, rse.loop->from[n]);
2299 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2302 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2303 rse.loop->to[n-1], rse.loop->from[n-1]);
2304 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2305 tmp_str, gfc_index_one_node);
2307 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2311 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2312 tmp_index, rse.loop->from[0]);
2313 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2315 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2316 rse.loop->loopvar[0], offset);
2318 /* Now use the offset for the reference. */
2319 tmp = build_fold_indirect_ref_loc (input_location,
2321 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2323 if (expr->ts.type == BT_CHARACTER)
2324 rse.string_length = expr->ts.u.cl->backend_decl;
2326 gfc_conv_expr (&lse, expr);
2328 gcc_assert (lse.ss == gfc_ss_terminator);
2330 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2331 gfc_add_expr_to_block (&body, tmp);
2333 /* Generate the copying loops. */
2334 gfc_trans_scalarizing_loops (&loop2, &body);
2336 /* Wrap the whole thing up by adding the second loop to the post-block
2337 and following it by the post-block of the first loop. In this way,
2338 if the temporary needs freeing, it is done after use! */
2339 if (intent != INTENT_IN)
2341 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2342 gfc_add_block_to_block (&parmse->post, &loop2.post);
2345 gfc_add_block_to_block (&parmse->post, &loop.post);
2347 gfc_cleanup_loop (&loop);
2348 gfc_cleanup_loop (&loop2);
2350 /* Pass the string length to the argument expression. */
2351 if (expr->ts.type == BT_CHARACTER)
2352 parmse->string_length = expr->ts.u.cl->backend_decl;
2354 /* We want either the address for the data or the address of the descriptor,
2355 depending on the mode of passing array arguments. */
2357 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2359 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2365 /* Generate the code for argument list functions. */
2368 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2370 /* Pass by value for g77 %VAL(arg), pass the address
2371 indirectly for %LOC, else by reference. Thus %REF
2372 is a "do-nothing" and %LOC is the same as an F95
2374 if (strncmp (name, "%VAL", 4) == 0)
2375 gfc_conv_expr (se, expr);
2376 else if (strncmp (name, "%LOC", 4) == 0)
2378 gfc_conv_expr_reference (se, expr);
2379 se->expr = gfc_build_addr_expr (NULL, se->expr);
2381 else if (strncmp (name, "%REF", 4) == 0)
2382 gfc_conv_expr_reference (se, expr);
2384 gfc_error ("Unknown argument list function at %L", &expr->where);
2388 /* Generate code for a procedure call. Note can return se->post != NULL.
2389 If se->direct_byref is set then se->expr contains the return parameter.
2390 Return nonzero, if the call has alternate specifiers.
2391 'expr' is only needed for procedure pointer components. */
2394 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2395 gfc_actual_arglist * arg, gfc_expr * expr,
2398 gfc_interface_mapping mapping;
2412 gfc_formal_arglist *formal;
2413 int has_alternate_specifier = 0;
2414 bool need_interface_mapping;
2421 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2422 gfc_component *comp = NULL;
2424 arglist = NULL_TREE;
2425 retargs = NULL_TREE;
2426 stringargs = NULL_TREE;
2431 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2433 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2435 if (arg->expr->rank == 0)
2436 gfc_conv_expr_reference (se, arg->expr);
2440 /* This is really the actual arg because no formal arglist is
2441 created for C_LOC. */
2442 fsym = arg->expr->symtree->n.sym;
2444 /* We should want it to do g77 calling convention. */
2446 && !(fsym->attr.pointer || fsym->attr.allocatable)
2447 && fsym->as->type != AS_ASSUMED_SHAPE;
2448 f = f || !sym->attr.always_explicit;
2450 argss = gfc_walk_expr (arg->expr);
2451 gfc_conv_array_parameter (se, arg->expr, argss, f,
2455 /* TODO -- the following two lines shouldn't be necessary, but
2456 they're removed a bug is exposed later in the codepath.
2457 This is workaround was thus introduced, but will have to be
2458 removed; please see PR 35150 for details about the issue. */
2459 se->expr = convert (pvoid_type_node, se->expr);
2460 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2464 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2466 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2467 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2468 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2469 gfc_conv_expr_reference (se, arg->expr);
2473 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2474 && arg->next->expr->rank == 0)
2475 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2477 /* Convert c_f_pointer if fptr is a scalar
2478 and convert c_f_procpointer. */
2482 gfc_init_se (&cptrse, NULL);
2483 gfc_conv_expr (&cptrse, arg->expr);
2484 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2485 gfc_add_block_to_block (&se->post, &cptrse.post);
2487 gfc_init_se (&fptrse, NULL);
2488 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2489 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2490 fptrse.want_pointer = 1;
2492 gfc_conv_expr (&fptrse, arg->next->expr);
2493 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2494 gfc_add_block_to_block (&se->post, &fptrse.post);
2496 if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2497 tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
2499 tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
2500 se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
2501 fold_convert (tmp, cptrse.expr));
2505 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2510 /* Build the addr_expr for the first argument. The argument is
2511 already an *address* so we don't need to set want_pointer in
2513 gfc_init_se (&arg1se, NULL);
2514 gfc_conv_expr (&arg1se, arg->expr);
2515 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2516 gfc_add_block_to_block (&se->post, &arg1se.post);
2518 /* See if we were given two arguments. */
2519 if (arg->next == NULL)
2520 /* Only given one arg so generate a null and do a
2521 not-equal comparison against the first arg. */
2522 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2523 fold_convert (TREE_TYPE (arg1se.expr),
2524 null_pointer_node));
2530 /* Given two arguments so build the arg2se from second arg. */
2531 gfc_init_se (&arg2se, NULL);
2532 gfc_conv_expr (&arg2se, arg->next->expr);
2533 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2534 gfc_add_block_to_block (&se->post, &arg2se.post);
2536 /* Generate test to compare that the two args are equal. */
2537 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2538 arg1se.expr, arg2se.expr);
2539 /* Generate test to ensure that the first arg is not null. */
2540 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2541 arg1se.expr, null_pointer_node);
2543 /* Finally, the generated test must check that both arg1 is not
2544 NULL and that it is equal to the second arg. */
2545 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2546 not_null_expr, eq_expr);
2553 gfc_is_proc_ptr_comp (expr, &comp);
2557 if (!sym->attr.elemental)
2559 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2560 if (se->ss->useflags)
2562 gcc_assert ((!comp && gfc_return_by_reference (sym)
2563 && sym->result->attr.dimension)
2564 || (comp && comp->attr.dimension));
2565 gcc_assert (se->loop != NULL);
2567 /* Access the previously obtained result. */
2568 gfc_conv_tmp_array_ref (se);
2569 gfc_advance_se_ss_chain (se);
2573 info = &se->ss->data.info;
2578 gfc_init_block (&post);
2579 gfc_init_interface_mapping (&mapping);
2580 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2581 && sym->ts.u.cl->length
2582 && sym->ts.u.cl->length->expr_type
2584 || (comp && comp->attr.dimension)
2585 || (!comp && sym->attr.dimension));
2587 formal = comp->formal;
2589 formal = sym->formal;
2590 /* Evaluate the arguments. */
2591 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2594 fsym = formal ? formal->sym : NULL;
2595 parm_kind = MISSING;
2599 if (se->ignore_optional)
2601 /* Some intrinsics have already been resolved to the correct
2605 else if (arg->label)
2607 has_alternate_specifier = 1;
2612 /* Pass a NULL pointer for an absent arg. */
2613 gfc_init_se (&parmse, NULL);
2614 parmse.expr = null_pointer_node;
2615 if (arg->missing_arg_type == BT_CHARACTER)
2616 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2619 else if (se->ss && se->ss->useflags)
2621 /* An elemental function inside a scalarized loop. */
2622 gfc_init_se (&parmse, se);
2623 gfc_conv_expr_reference (&parmse, e);
2624 parm_kind = ELEMENTAL;
2628 /* A scalar or transformational function. */
2629 gfc_init_se (&parmse, NULL);
2630 argss = gfc_walk_expr (e);
2632 if (argss == gfc_ss_terminator)
2634 if (e->expr_type == EXPR_VARIABLE
2635 && e->symtree->n.sym->attr.cray_pointee
2636 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2638 /* The Cray pointer needs to be converted to a pointer to
2639 a type given by the expression. */
2640 gfc_conv_expr (&parmse, e);
2641 type = build_pointer_type (TREE_TYPE (parmse.expr));
2642 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2643 parmse.expr = convert (type, tmp);
2645 else if (fsym && fsym->attr.value)
2647 if (fsym->ts.type == BT_CHARACTER
2648 && fsym->ts.is_c_interop
2649 && fsym->ns->proc_name != NULL
2650 && fsym->ns->proc_name->attr.is_bind_c)
2653 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2654 if (parmse.expr == NULL)
2655 gfc_conv_expr (&parmse, e);
2658 gfc_conv_expr (&parmse, e);
2660 else if (arg->name && arg->name[0] == '%')
2661 /* Argument list functions %VAL, %LOC and %REF are signalled
2662 through arg->name. */
2663 conv_arglist_function (&parmse, arg->expr, arg->name);
2664 else if ((e->expr_type == EXPR_FUNCTION)
2665 && e->symtree->n.sym->attr.pointer
2666 && fsym && fsym->attr.target)
2668 gfc_conv_expr (&parmse, e);
2669 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2671 else if (e->expr_type == EXPR_FUNCTION
2672 && e->symtree->n.sym->result
2673 && e->symtree->n.sym->result->attr.proc_pointer)
2675 /* Functions returning procedure pointers. */
2676 gfc_conv_expr (&parmse, e);
2677 if (fsym && fsym->attr.proc_pointer)
2678 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2682 gfc_conv_expr_reference (&parmse, e);
2683 if (fsym && e->expr_type != EXPR_NULL
2684 && ((fsym->attr.pointer
2685 && fsym->attr.flavor != FL_PROCEDURE)
2686 || (fsym->attr.proc_pointer
2687 && !(e->expr_type == EXPR_VARIABLE
2688 && e->symtree->n.sym->attr.dummy))
2689 || gfc_is_proc_ptr_comp (e, NULL)))
2691 /* Scalar pointer dummy args require an extra level of
2692 indirection. The null pointer already contains
2693 this level of indirection. */
2694 parm_kind = SCALAR_POINTER;
2695 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2701 /* If the procedure requires an explicit interface, the actual
2702 argument is passed according to the corresponding formal
2703 argument. If the corresponding formal argument is a POINTER,
2704 ALLOCATABLE or assumed shape, we do not use g77's calling
2705 convention, and pass the address of the array descriptor
2706 instead. Otherwise we use g77's calling convention. */
2709 && !(fsym->attr.pointer || fsym->attr.allocatable)
2710 && fsym->as->type != AS_ASSUMED_SHAPE;
2711 f = f || !sym->attr.always_explicit;
2713 if (e->expr_type == EXPR_VARIABLE
2714 && is_subref_array (e))
2715 /* The actual argument is a component reference to an
2716 array of derived types. In this case, the argument
2717 is converted to a temporary, which is passed and then
2718 written back after the procedure call. */
2719 gfc_conv_subref_array_arg (&parmse, e, f,
2720 fsym ? fsym->attr.intent : INTENT_INOUT);
2722 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2725 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2726 allocated on entry, it must be deallocated. */
2727 if (fsym && fsym->attr.allocatable
2728 && fsym->attr.intent == INTENT_OUT)
2730 tmp = build_fold_indirect_ref_loc (input_location,
2732 tmp = gfc_trans_dealloc_allocated (tmp);
2733 gfc_add_expr_to_block (&se->pre, tmp);
2739 /* The case with fsym->attr.optional is that of a user subroutine
2740 with an interface indicating an optional argument. When we call
2741 an intrinsic subroutine, however, fsym is NULL, but we might still
2742 have an optional argument, so we proceed to the substitution
2744 if (e && (fsym == NULL || fsym->attr.optional))
2746 /* If an optional argument is itself an optional dummy argument,
2747 check its presence and substitute a null if absent. */
2748 if (e->expr_type == EXPR_VARIABLE
2749 && e->symtree->n.sym->attr.optional)
2750 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2751 e->representation.length);
2756 /* Obtain the character length of an assumed character length
2757 length procedure from the typespec. */
2758 if (fsym->ts.type == BT_CHARACTER
2759 && parmse.string_length == NULL_TREE
2760 && e->ts.type == BT_PROCEDURE
2761 && e->symtree->n.sym->ts.type == BT_CHARACTER
2762 && e->symtree->n.sym->ts.u.cl->length != NULL
2763 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2765 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
2766 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
2770 if (fsym && need_interface_mapping && e)
2771 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2773 gfc_add_block_to_block (&se->pre, &parmse.pre);
2774 gfc_add_block_to_block (&post, &parmse.post);
2776 /* Allocated allocatable components of derived types must be
2777 deallocated for non-variable scalars. Non-variable arrays are
2778 dealt with in trans-array.c(gfc_conv_array_parameter). */
2779 if (e && e->ts.type == BT_DERIVED
2780 && e->ts.u.derived->attr.alloc_comp
2781 && !(e->symtree && e->symtree->n.sym->attr.pointer)
2782 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2785 tmp = build_fold_indirect_ref_loc (input_location,
2787 parm_rank = e->rank;
2795 case (SCALAR_POINTER):
2796 tmp = build_fold_indirect_ref_loc (input_location,
2801 if (e->expr_type == EXPR_OP
2802 && e->value.op.op == INTRINSIC_PARENTHESES
2803 && e->value.op.op1->expr_type == EXPR_VARIABLE)
2806 local_tmp = gfc_evaluate_now (tmp, &se->pre);
2807 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
2808 gfc_add_expr_to_block (&se->post, local_tmp);
2811 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
2813 gfc_add_expr_to_block (&se->post, tmp);
2816 /* Add argument checking of passing an unallocated/NULL actual to
2817 a nonallocatable/nonpointer dummy. */
2819 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
2821 symbol_attribute *attr;
2825 if (e->expr_type == EXPR_VARIABLE)
2826 attr = &e->symtree->n.sym->attr;
2827 else if (e->expr_type == EXPR_FUNCTION)
2829 /* For intrinsic functions, the gfc_attr are not available. */
2830 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
2831 goto end_pointer_check;
2833 if (e->symtree->n.sym->attr.generic)
2834 attr = &e->value.function.esym->attr;
2836 attr = &e->symtree->n.sym->result->attr;
2839 goto end_pointer_check;
2843 /* If the actual argument is an optional pointer/allocatable and
2844 the formal argument takes an nonpointer optional value,
2845 it is invalid to pass a non-present argument on, even
2846 though there is no technical reason for this in gfortran.
2847 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
2848 tree present, nullptr, type;
2850 if (attr->allocatable
2851 && (fsym == NULL || !fsym->attr.allocatable))
2852 asprintf (&msg, "Allocatable actual argument '%s' is not "
2853 "allocated or not present", e->symtree->n.sym->name);
2854 else if (attr->pointer
2855 && (fsym == NULL || !fsym->attr.pointer))
2856 asprintf (&msg, "Pointer actual argument '%s' is not "
2857 "associated or not present",
2858 e->symtree->n.sym->name);
2859 else if (attr->proc_pointer
2860 && (fsym == NULL || !fsym->attr.proc_pointer))
2861 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2862 "associated or not present",
2863 e->symtree->n.sym->name);
2865 goto end_pointer_check;
2867 present = gfc_conv_expr_present (e->symtree->n.sym);
2868 type = TREE_TYPE (present);
2869 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
2870 fold_convert (type, null_pointer_node));
2871 type = TREE_TYPE (parmse.expr);
2872 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2873 fold_convert (type, null_pointer_node));
2874 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
2879 if (attr->allocatable
2880 && (fsym == NULL || !fsym->attr.allocatable))
2881 asprintf (&msg, "Allocatable actual argument '%s' is not "
2882 "allocated", e->symtree->n.sym->name);
2883 else if (attr->pointer
2884 && (fsym == NULL || !fsym->attr.pointer))
2885 asprintf (&msg, "Pointer actual argument '%s' is not "
2886 "associated", e->symtree->n.sym->name);
2887 else if (attr->proc_pointer
2888 && (fsym == NULL || !fsym->attr.proc_pointer))
2889 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2890 "associated", e->symtree->n.sym->name);
2892 goto end_pointer_check;
2895 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2896 fold_convert (TREE_TYPE (parmse.expr),
2897 null_pointer_node));
2900 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
2907 /* Character strings are passed as two parameters, a length and a
2908 pointer - except for Bind(c) which only passes the pointer. */
2909 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2910 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2912 arglist = gfc_chainon_list (arglist, parmse.expr);
2914 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2917 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2918 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2919 else if (ts.type == BT_CHARACTER)
2921 if (sym->ts.u.cl->length == NULL)
2923 /* Assumed character length results are not allowed by 5.1.1.5 of the
2924 standard and are trapped in resolve.c; except in the case of SPREAD
2925 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2926 we take the character length of the first argument for the result.
2927 For dummies, we have to look through the formal argument list for
2928 this function and use the character length found there.*/
2929 if (!sym->attr.dummy)
2930 cl.backend_decl = TREE_VALUE (stringargs);
2933 formal = sym->ns->proc_name->formal;
2934 for (; formal; formal = formal->next)
2935 if (strcmp (formal->sym->name, sym->name) == 0)
2936 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
2943 /* Calculate the length of the returned string. */
2944 gfc_init_se (&parmse, NULL);
2945 if (need_interface_mapping)
2946 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
2948 gfc_conv_expr (&parmse, sym->ts.u.cl->length);
2949 gfc_add_block_to_block (&se->pre, &parmse.pre);
2950 gfc_add_block_to_block (&se->post, &parmse.post);
2952 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2953 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2954 build_int_cst (gfc_charlen_type_node, 0));
2955 cl.backend_decl = tmp;
2958 /* Set up a charlen structure for it. */
2963 len = cl.backend_decl;
2966 byref = (comp && comp->attr.dimension)
2967 || (!comp && gfc_return_by_reference (sym));
2970 if (se->direct_byref)
2972 /* Sometimes, too much indirection can be applied; e.g. for
2973 function_result = array_valued_recursive_function. */
2974 if (TREE_TYPE (TREE_TYPE (se->expr))
2975 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2976 && GFC_DESCRIPTOR_TYPE_P
2977 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2978 se->expr = build_fold_indirect_ref_loc (input_location,
2981 retargs = gfc_chainon_list (retargs, se->expr);
2983 else if (comp && comp->attr.dimension)
2985 gcc_assert (se->loop && info);
2987 /* Set the type of the array. */
2988 tmp = gfc_typenode_for_spec (&comp->ts);
2989 info->dimen = se->loop->dimen;
2991 /* Evaluate the bounds of the result, if known. */
2992 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
2994 /* Create a temporary to store the result. In case the function
2995 returns a pointer, the temporary will be a shallow copy and
2996 mustn't be deallocated. */
2997 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
2998 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2999 NULL_TREE, false, !comp->attr.pointer,
3000 callee_alloc, &se->ss->expr->where);
3002 /* Pass the temporary as the first argument. */
3003 tmp = info->descriptor;
3004 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3005 retargs = gfc_chainon_list (retargs, tmp);
3007 else if (sym->result->attr.dimension)
3009 gcc_assert (se->loop && info);
3011 /* Set the type of the array. */
3012 tmp = gfc_typenode_for_spec (&ts);
3013 info->dimen = se->loop->dimen;
3015 /* Evaluate the bounds of the result, if known. */
3016 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3018 /* Create a temporary to store the result. In case the function
3019 returns a pointer, the temporary will be a shallow copy and
3020 mustn't be deallocated. */
3021 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3022 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3023 NULL_TREE, false, !sym->attr.pointer,
3024 callee_alloc, &se->ss->expr->where);
3026 /* Pass the temporary as the first argument. */
3027 tmp = info->descriptor;
3028 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3029 retargs = gfc_chainon_list (retargs, tmp);
3031 else if (ts.type == BT_CHARACTER)
3033 /* Pass the string length. */
3034 type = gfc_get_character_type (ts.kind, ts.u.cl);
3035 type = build_pointer_type (type);
3037 /* Return an address to a char[0:len-1]* temporary for
3038 character pointers. */
3039 if (sym->attr.pointer || sym->attr.allocatable)
3041 var = gfc_create_var (type, "pstr");
3043 /* Provide an address expression for the function arguments. */
3044 var = gfc_build_addr_expr (NULL_TREE, var);
3047 var = gfc_conv_string_tmp (se, type, len);
3049 retargs = gfc_chainon_list (retargs, var);
3053 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3055 type = gfc_get_complex_type (ts.kind);
3056 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3057 retargs = gfc_chainon_list (retargs, var);
3060 /* Add the string length to the argument list. */
3061 if (ts.type == BT_CHARACTER)
3062 retargs = gfc_chainon_list (retargs, len);
3064 gfc_free_interface_mapping (&mapping);
3066 /* Add the return arguments. */
3067 arglist = chainon (retargs, arglist);
3069 /* Add the hidden string length parameters to the arguments. */
3070 arglist = chainon (arglist, stringargs);
3072 /* We may want to append extra arguments here. This is used e.g. for
3073 calls to libgfortran_matmul_??, which need extra information. */
3074 if (append_args != NULL_TREE)
3075 arglist = chainon (arglist, append_args);
3077 /* Generate the actual call. */
3078 conv_function_val (se, sym, expr);
3080 /* If there are alternate return labels, function type should be
3081 integer. Can't modify the type in place though, since it can be shared
3082 with other functions. For dummy arguments, the typing is done to
3083 to this result, even if it has to be repeated for each call. */
3084 if (has_alternate_specifier
3085 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3087 if (!sym->attr.dummy)
3089 TREE_TYPE (sym->backend_decl)
3090 = build_function_type (integer_type_node,
3091 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3092 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3095 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3098 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3099 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3101 /* If we have a pointer function, but we don't want a pointer, e.g.
3104 where f is pointer valued, we have to dereference the result. */
3105 if (!se->want_pointer && !byref && sym->attr.pointer
3106 && !gfc_is_proc_ptr_comp (expr, NULL))
3107 se->expr = build_fold_indirect_ref_loc (input_location,
3110 /* f2c calling conventions require a scalar default real function to
3111 return a double precision result. Convert this back to default
3112 real. We only care about the cases that can happen in Fortran 77.
3114 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3115 && sym->ts.kind == gfc_default_real_kind
3116 && !sym->attr.always_explicit)
3117 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3119 /* A pure function may still have side-effects - it may modify its
3121 TREE_SIDE_EFFECTS (se->expr) = 1;
3123 if (!sym->attr.pure)
3124 TREE_SIDE_EFFECTS (se->expr) = 1;
3129 /* Add the function call to the pre chain. There is no expression. */
3130 gfc_add_expr_to_block (&se->pre, se->expr);
3131 se->expr = NULL_TREE;
3133 if (!se->direct_byref)
3135 if (sym->attr.dimension || (comp && comp->attr.dimension))
3137 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3139 /* Check the data pointer hasn't been modified. This would
3140 happen in a function returning a pointer. */
3141 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3142 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3144 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3147 se->expr = info->descriptor;
3148 /* Bundle in the string length. */
3149 se->string_length = len;
3151 else if (sym->ts.type == BT_CHARACTER)
3153 /* Dereference for character pointer results. */
3154 if (sym->attr.pointer || sym->attr.allocatable)
3155 se->expr = build_fold_indirect_ref_loc (input_location,
3160 se->string_length = len;
3164 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3165 se->expr = build_fold_indirect_ref_loc (input_location,
3171 /* Follow the function call with the argument post block. */
3173 gfc_add_block_to_block (&se->pre, &post);
3175 gfc_add_block_to_block (&se->post, &post);
3177 return has_alternate_specifier;
3181 /* Fill a character string with spaces. */
3184 fill_with_spaces (tree start, tree type, tree size)
3186 stmtblock_t block, loop;
3187 tree i, el, exit_label, cond, tmp;
3189 /* For a simple char type, we can call memset(). */
3190 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3191 return build_call_expr_loc (input_location,
3192 built_in_decls[BUILT_IN_MEMSET], 3, start,
3193 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3194 lang_hooks.to_target_charset (' ')),
3197 /* Otherwise, we use a loop:
3198 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3202 /* Initialize variables. */
3203 gfc_init_block (&block);
3204 i = gfc_create_var (sizetype, "i");
3205 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3206 el = gfc_create_var (build_pointer_type (type), "el");
3207 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3208 exit_label = gfc_build_label_decl (NULL_TREE);
3209 TREE_USED (exit_label) = 1;
3213 gfc_init_block (&loop);
3215 /* Exit condition. */
3216 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3217 fold_convert (sizetype, integer_zero_node));
3218 tmp = build1_v (GOTO_EXPR, exit_label);
3219 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3220 build_empty_stmt (input_location));
3221 gfc_add_expr_to_block (&loop, tmp);
3224 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3225 build_int_cst (type,
3226 lang_hooks.to_target_charset (' ')));
3228 /* Increment loop variables. */
3229 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3230 TYPE_SIZE_UNIT (type)));
3231 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3233 TYPE_SIZE_UNIT (type)));
3235 /* Making the loop... actually loop! */
3236 tmp = gfc_finish_block (&loop);
3237 tmp = build1_v (LOOP_EXPR, tmp);
3238 gfc_add_expr_to_block (&block, tmp);
3240 /* The exit label. */
3241 tmp = build1_v (LABEL_EXPR, exit_label);
3242 gfc_add_expr_to_block (&block, tmp);
3245 return gfc_finish_block (&block);
3249 /* Generate code to copy a string. */
3252 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3253 int dkind, tree slength, tree src, int skind)
3255 tree tmp, dlen, slen;
3264 stmtblock_t tempblock;
3266 gcc_assert (dkind == skind);
3268 if (slength != NULL_TREE)
3270 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3271 ssc = string_to_single_character (slen, src, skind);
3275 slen = build_int_cst (size_type_node, 1);
3279 if (dlength != NULL_TREE)
3281 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3282 dsc = string_to_single_character (slen, dest, dkind);
3286 dlen = build_int_cst (size_type_node, 1);
3290 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3291 ssc = string_to_single_character (slen, src, skind);
3292 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3293 dsc = string_to_single_character (dlen, dest, dkind);
3296 /* Assign directly if the types are compatible. */
3297 if (dsc != NULL_TREE && ssc != NULL_TREE
3298 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3300 gfc_add_modify (block, dsc, ssc);
3304 /* Do nothing if the destination length is zero. */
3305 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3306 build_int_cst (size_type_node, 0));
3308 /* The following code was previously in _gfortran_copy_string:
3310 // The two strings may overlap so we use memmove.
3312 copy_string (GFC_INTEGER_4 destlen, char * dest,
3313 GFC_INTEGER_4 srclen, const char * src)
3315 if (srclen >= destlen)
3317 // This will truncate if too long.
3318 memmove (dest, src, destlen);
3322 memmove (dest, src, srclen);
3324 memset (&dest[srclen], ' ', destlen - srclen);
3328 We're now doing it here for better optimization, but the logic
3331 /* For non-default character kinds, we have to multiply the string
3332 length by the base type size. */
3333 chartype = gfc_get_char_type (dkind);
3334 slen = fold_build2 (MULT_EXPR, size_type_node,
3335 fold_convert (size_type_node, slen),
3336 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3337 dlen = fold_build2 (MULT_EXPR, size_type_node,
3338 fold_convert (size_type_node, dlen),
3339 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3342 dest = fold_convert (pvoid_type_node, dest);
3344 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3347 src = fold_convert (pvoid_type_node, src);
3349 src = gfc_build_addr_expr (pvoid_type_node, src);
3351 /* Truncate string if source is too long. */
3352 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3353 tmp2 = build_call_expr_loc (input_location,
3354 built_in_decls[BUILT_IN_MEMMOVE],
3355 3, dest, src, dlen);
3357 /* Else copy and pad with spaces. */
3358 tmp3 = build_call_expr_loc (input_location,
3359 built_in_decls[BUILT_IN_MEMMOVE],
3360 3, dest, src, slen);
3362 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3363 fold_convert (sizetype, slen));
3364 tmp4 = fill_with_spaces (tmp4, chartype,
3365 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3368 gfc_init_block (&tempblock);
3369 gfc_add_expr_to_block (&tempblock, tmp3);
3370 gfc_add_expr_to_block (&tempblock, tmp4);
3371 tmp3 = gfc_finish_block (&tempblock);
3373 /* The whole copy_string function is there. */
3374 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3375 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3376 build_empty_stmt (input_location));
3377 gfc_add_expr_to_block (block, tmp);
3381 /* Translate a statement function.
3382 The value of a statement function reference is obtained by evaluating the
3383 expression using the values of the actual arguments for the values of the
3384 corresponding dummy arguments. */
3387 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3391 gfc_formal_arglist *fargs;
3392 gfc_actual_arglist *args;
3395 gfc_saved_var *saved_vars;
3401 sym = expr->symtree->n.sym;
3402 args = expr->value.function.actual;
3403 gfc_init_se (&lse, NULL);
3404 gfc_init_se (&rse, NULL);
3407 for (fargs = sym->formal; fargs; fargs = fargs->next)
3409 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3410 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3412 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3414 /* Each dummy shall be specified, explicitly or implicitly, to be
3416 gcc_assert (fargs->sym->attr.dimension == 0);
3419 /* Create a temporary to hold the value. */
3420 type = gfc_typenode_for_spec (&fsym->ts);
3421 temp_vars[n] = gfc_create_var (type, fsym->name);
3423 if (fsym->ts.type == BT_CHARACTER)
3425 /* Copy string arguments. */
3428 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3429 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3431 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3432 tmp = gfc_build_addr_expr (build_pointer_type (type),
3435 gfc_conv_expr (&rse, args->expr);
3436 gfc_conv_string_parameter (&rse);
3437 gfc_add_block_to_block (&se->pre, &lse.pre);
3438 gfc_add_block_to_block (&se->pre, &rse.pre);
3440 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3441 rse.string_length, rse.expr, fsym->ts.kind);
3442 gfc_add_block_to_block (&se->pre, &lse.post);
3443 gfc_add_block_to_block (&se->pre, &rse.post);
3447 /* For everything else, just evaluate the expression. */
3448 gfc_conv_expr (&lse, args->expr);
3450 gfc_add_block_to_block (&se->pre, &lse.pre);
3451 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3452 gfc_add_block_to_block (&se->pre, &lse.post);
3458 /* Use the temporary variables in place of the real ones. */
3459 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3460 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3462 gfc_conv_expr (se, sym->value);
3464 if (sym->ts.type == BT_CHARACTER)
3466 gfc_conv_const_charlen (sym->ts.u.cl);
3468 /* Force the expression to the correct length. */
3469 if (!INTEGER_CST_P (se->string_length)
3470 || tree_int_cst_lt (se->string_length,
3471 sym->ts.u.cl->backend_decl))
3473 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3474 tmp = gfc_create_var (type, sym->name);
3475 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3476 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3477 sym->ts.kind, se->string_length, se->expr,
3481 se->string_length = sym->ts.u.cl->backend_decl;
3484 /* Restore the original variables. */
3485 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3486 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3487 gfc_free (saved_vars);
3491 /* Return the backend_decl for a procedure pointer component. */
3494 gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
3498 gfc_init_se (&comp_se, NULL);
3499 e2 = gfc_copy_expr (e);
3500 e2->expr_type = EXPR_VARIABLE;
3501 gfc_conv_expr (&comp_se, e2);
3502 comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr);
3503 return gfc_evaluate_now (comp_se.expr, &se->pre);
3507 /* Translate a function expression. */
3510 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3514 if (expr->value.function.isym)
3516 gfc_conv_intrinsic_function (se, expr);
3520 /* We distinguish statement functions from general functions to improve
3521 runtime performance. */
3522 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3524 gfc_conv_statement_function (se, expr);
3528 /* expr.value.function.esym is the resolved (specific) function symbol for
3529 most functions. However this isn't set for dummy procedures. */
3530 sym = expr->value.function.esym;
3532 sym = expr->symtree->n.sym;
3534 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3540 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3542 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3543 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3545 gfc_conv_tmp_array_ref (se);
3546 gfc_advance_se_ss_chain (se);
3550 /* Build a static initializer. EXPR is the expression for the initial value.
3551 The other parameters describe the variable of the component being
3552 initialized. EXPR may be null. */
3555 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3556 bool array, bool pointer)
3560 if (!(expr || pointer))
3563 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3564 (these are the only two iso_c_binding derived types that can be
3565 used as initialization expressions). If so, we need to modify
3566 the 'expr' to be that for a (void *). */
3567 if (expr != NULL && expr->ts.type == BT_DERIVED
3568 && expr->ts.is_iso_c && expr->ts.u.derived)
3570 gfc_symbol *derived = expr->ts.u.derived;
3572 expr = gfc_int_expr (0);
3574 /* The derived symbol has already been converted to a (void *). Use
3576 expr->ts.f90_type = derived->ts.f90_type;
3577 expr->ts.kind = derived->ts.kind;
3582 /* Arrays need special handling. */
3584 return gfc_build_null_descriptor (type);
3586 return gfc_conv_array_initializer (type, expr);
3589 return fold_convert (type, null_pointer_node);
3595 gfc_init_se (&se, NULL);
3596 gfc_conv_structure (&se, expr, 1);
3600 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3603 gfc_init_se (&se, NULL);
3604 gfc_conv_constant (&se, expr);
3611 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3623 gfc_start_block (&block);
3625 /* Initialize the scalarizer. */
3626 gfc_init_loopinfo (&loop);
3628 gfc_init_se (&lse, NULL);
3629 gfc_init_se (&rse, NULL);
3632 rss = gfc_walk_expr (expr);
3633 if (rss == gfc_ss_terminator)
3635 /* The rhs is scalar. Add a ss for the expression. */
3636 rss = gfc_get_ss ();
3637 rss->next = gfc_ss_terminator;
3638 rss->type = GFC_SS_SCALAR;
3642 /* Create a SS for the destination. */
3643 lss = gfc_get_ss ();
3644 lss->type = GFC_SS_COMPONENT;
3646 lss->shape = gfc_get_shape (cm->as->rank);
3647 lss->next = gfc_ss_terminator;
3648 lss->data.info.dimen = cm->as->rank;
3649 lss->data.info.descriptor = dest;
3650 lss->data.info.data = gfc_conv_array_data (dest);
3651 lss->data.info.offset = gfc_conv_array_offset (dest);
3652 for (n = 0; n < cm->as->rank; n++)
3654 lss->data.info.dim[n] = n;
3655 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3656 lss->data.info.stride[n] = gfc_index_one_node;
3658 mpz_init (lss->shape[n]);
3659 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3660 cm->as->lower[n]->value.integer);
3661 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3664 /* Associate the SS with the loop. */
3665 gfc_add_ss_to_loop (&loop, lss);
3666 gfc_add_ss_to_loop (&loop, rss);
3668 /* Calculate the bounds of the scalarization. */
3669 gfc_conv_ss_startstride (&loop);
3671 /* Setup the scalarizing loops. */
3672 gfc_conv_loop_setup (&loop, &expr->where);
3674 /* Setup the gfc_se structures. */
3675 gfc_copy_loopinfo_to_se (&lse, &loop);
3676 gfc_copy_loopinfo_to_se (&rse, &loop);
3679 gfc_mark_ss_chain_used (rss, 1);
3681 gfc_mark_ss_chain_used (lss, 1);
3683 /* Start the scalarized loop body. */
3684 gfc_start_scalarized_body (&loop, &body);
3686 gfc_conv_tmp_array_ref (&lse);
3687 if (cm->ts.type == BT_CHARACTER)
3688 lse.string_length = cm->ts.u.cl->backend_decl;
3690 gfc_conv_expr (&rse, expr);
3692 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3693 gfc_add_expr_to_block (&body, tmp);
3695 gcc_assert (rse.ss == gfc_ss_terminator);
3697 /* Generate the copying loops. */
3698 gfc_trans_scalarizing_loops (&loop, &body);
3700 /* Wrap the whole thing up. */
3701 gfc_add_block_to_block (&block, &loop.pre);
3702 gfc_add_block_to_block (&block, &loop.post);
3704 for (n = 0; n < cm->as->rank; n++)
3705 mpz_clear (lss->shape[n]);
3706 gfc_free (lss->shape);
3708 gfc_cleanup_loop (&loop);
3710 return gfc_finish_block (&block);
3714 /* Assign a single component of a derived type constructor. */
3717 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3727 gfc_start_block (&block);
3729 if (cm->attr.pointer)
3731 gfc_init_se (&se, NULL);
3732 /* Pointer component. */
3733 if (cm->attr.dimension)
3735 /* Array pointer. */
3736 if (expr->expr_type == EXPR_NULL)
3737 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3740 rss = gfc_walk_expr (expr);
3741 se.direct_byref = 1;
3743 gfc_conv_expr_descriptor (&se, expr, rss);
3744 gfc_add_block_to_block (&block, &se.pre);
3745 gfc_add_block_to_block (&block, &se.post);
3750 /* Scalar pointers. */
3751 se.want_pointer = 1;
3752 gfc_conv_expr (&se, expr);
3753 gfc_add_block_to_block (&block, &se.pre);
3754 gfc_add_modify (&block, dest,
3755 fold_convert (TREE_TYPE (dest), se.expr));
3756 gfc_add_block_to_block (&block, &se.post);
3759 else if (cm->attr.dimension)
3761 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3762 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3763 else if (cm->attr.allocatable)
3767 gfc_init_se (&se, NULL);
3769 rss = gfc_walk_expr (expr);
3770 se.want_pointer = 0;
3771 gfc_conv_expr_descriptor (&se, expr, rss);
3772 gfc_add_block_to_block (&block, &se.pre);
3773 gfc_add_modify (&block, dest, se.expr);
3775 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
3776 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
3779 tmp = gfc_duplicate_allocatable (dest, se.expr,
3780 TREE_TYPE(cm->backend_decl),
3783 gfc_add_expr_to_block (&block, tmp);
3784 gfc_add_block_to_block (&block, &se.post);
3786 if (expr->expr_type != EXPR_VARIABLE)
3787 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3789 /* Shift the lbound and ubound of temporaries to being unity, rather
3790 than zero, based. Calculate the offset for all cases. */
3791 offset = gfc_conv_descriptor_offset_get (dest);
3792 gfc_add_modify (&block, offset, gfc_index_zero_node);
3793 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3794 for (n = 0; n < expr->rank; n++)
3796 if (expr->expr_type != EXPR_VARIABLE
3797 && expr->expr_type != EXPR_CONSTANT)
3800 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
3801 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3802 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
3803 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3804 span, gfc_index_one_node);
3805 gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
3807 gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
3808 gfc_index_one_node);
3810 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3811 gfc_conv_descriptor_lbound_get (dest,
3813 gfc_conv_descriptor_stride_get (dest,
3815 gfc_add_modify (&block, tmp2, tmp);
3816 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3817 gfc_conv_descriptor_offset_set (&block, dest, tmp);
3820 if (expr->expr_type == EXPR_FUNCTION
3821 && expr->value.function.isym
3822 && expr->value.function.isym->conversion
3823 && expr->value.function.actual->expr
3824 && expr->value.function.actual->expr->expr_type
3827 /* If a conversion expression has a null data pointer
3828 argument, nullify the allocatable component. */
3832 s = expr->value.function.actual->expr->symtree->n.sym;
3833 if (s->attr.allocatable || s->attr.pointer)
3835 non_null_expr = gfc_finish_block (&block);
3836 gfc_start_block (&block);
3837 gfc_conv_descriptor_data_set (&block, dest,
3839 null_expr = gfc_finish_block (&block);
3840 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
3841 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
3842 fold_convert (TREE_TYPE (tmp),
3843 null_pointer_node));
3844 return build3_v (COND_EXPR, tmp, null_expr,
3851 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3852 gfc_add_expr_to_block (&block, tmp);
3855 else if (expr->ts.type == BT_DERIVED)
3857 if (expr->expr_type != EXPR_STRUCTURE)
3859 gfc_init_se (&se, NULL);
3860 gfc_conv_expr (&se, expr);
3861 gfc_add_block_to_block (&block, &se.pre);
3862 gfc_add_modify (&block, dest,
3863 fold_convert (TREE_TYPE (dest), se.expr));
3864 gfc_add_block_to_block (&block, &se.post);
3868 /* Nested constructors. */
3869 tmp = gfc_trans_structure_assign (dest, expr);
3870 gfc_add_expr_to_block (&block, tmp);
3875 /* Scalar component. */
3876 gfc_init_se (&se, NULL);
3877 gfc_init_se (&lse, NULL);
3879 gfc_conv_expr (&se, expr);
3880 if (cm->ts.type == BT_CHARACTER)
3881 lse.string_length = cm->ts.u.cl->backend_decl;
3883 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3884 gfc_add_expr_to_block (&block, tmp);
3886 return gfc_finish_block (&block);
3889 /* Assign a derived type constructor to a variable. */
3892 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3900 gfc_start_block (&block);
3901 cm = expr->ts.u.derived->components;
3902 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3904 /* Skip absent members in default initializers. */
3908 field = cm->backend_decl;
3909 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3910 dest, field, NULL_TREE);
3911 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3912 gfc_add_expr_to_block (&block, tmp);
3914 return gfc_finish_block (&block);
3917 /* Build an expression for a constructor. If init is nonzero then
3918 this is part of a static variable initializer. */
3921 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3928 VEC(constructor_elt,gc) *v = NULL;
3930 gcc_assert (se->ss == NULL);
3931 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3932 type = gfc_typenode_for_spec (&expr->ts);
3936 /* Create a temporary variable and fill it in. */
3937 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
3938 tmp = gfc_trans_structure_assign (se->expr, expr);
3939 gfc_add_expr_to_block (&se->pre, tmp);
3943 cm = expr->ts.u.derived->components;
3945 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3947 /* Skip absent members in default initializers and allocatable
3948 components. Although the latter have a default initializer
3949 of EXPR_NULL,... by default, the static nullify is not needed
3950 since this is done every time we come into scope. */
3951 if (!c->expr || cm->attr.allocatable)
3954 val = gfc_conv_initializer (c->expr, &cm->ts,
3955 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
3956 cm->attr.pointer || cm->attr.proc_pointer);
3958 /* Append it to the constructor list. */
3959 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3961 se->expr = build_constructor (type, v);
3963 TREE_CONSTANT (se->expr) = 1;
3967 /* Translate a substring expression. */
3970 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3976 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3978 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3979 expr->value.character.length,
3980 expr->value.character.string);
3982 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3983 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3986 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3990 /* Entry point for expression translation. Evaluates a scalar quantity.
3991 EXPR is the expression to be translated, and SE is the state structure if
3992 called from within the scalarized. */
3995 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3997 if (se->ss && se->ss->expr == expr
3998 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4000 /* Substitute a scalar expression evaluated outside the scalarization
4002 se->expr = se->ss->data.scalar.expr;
4003 se->string_length = se->ss->string_length;
4004 gfc_advance_se_ss_chain (se);
4008 /* We need to convert the expressions for the iso_c_binding derived types.
4009 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4010 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4011 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4012 updated to be an integer with a kind equal to the size of a (void *). */
4013 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4014 && expr->ts.u.derived->attr.is_iso_c)
4016 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4017 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4019 /* Set expr_type to EXPR_NULL, which will result in
4020 null_pointer_node being used below. */
4021 expr->expr_type = EXPR_NULL;
4025 /* Update the type/kind of the expression to be what the new
4026 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4027 expr->ts.type = expr->ts.u.derived->ts.type;
4028 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4029 expr->ts.kind = expr->ts.u.derived->ts.kind;
4033 switch (expr->expr_type)
4036 gfc_conv_expr_op (se, expr);
4040 gfc_conv_function_expr (se, expr);
4044 gfc_conv_constant (se, expr);
4048 gfc_conv_variable (se, expr);
4052 se->expr = null_pointer_node;
4055 case EXPR_SUBSTRING:
4056 gfc_conv_substring_expr (se, expr);
4059 case EXPR_STRUCTURE:
4060 gfc_conv_structure (se, expr, 0);
4064 gfc_conv_array_constructor_expr (se, expr);
4073 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4074 of an assignment. */
4076 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4078 gfc_conv_expr (se, expr);
4079 /* All numeric lvalues should have empty post chains. If not we need to
4080 figure out a way of rewriting an lvalue so that it has no post chain. */
4081 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4084 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4085 numeric expressions. Used for scalar values where inserting cleanup code
4088 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4092 gcc_assert (expr->ts.type != BT_CHARACTER);
4093 gfc_conv_expr (se, expr);
4096 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4097 gfc_add_modify (&se->pre, val, se->expr);
4099 gfc_add_block_to_block (&se->pre, &se->post);
4103 /* Helper to translate an expression and convert it to a particular type. */
4105 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4107 gfc_conv_expr_val (se, expr);
4108 se->expr = convert (type, se->expr);
4112 /* Converts an expression so that it can be passed by reference. Scalar
4116 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4120 if (se->ss && se->ss->expr == expr
4121 && se->ss->type == GFC_SS_REFERENCE)
4123 se->expr = se->ss->data.scalar.expr;
4124 se->string_length = se->ss->string_length;
4125 gfc_advance_se_ss_chain (se);
4129 if (expr->ts.type == BT_CHARACTER)
4131 gfc_conv_expr (se, expr);
4132 gfc_conv_string_parameter (se);
4136 if (expr->expr_type == EXPR_VARIABLE)
4138 se->want_pointer = 1;
4139 gfc_conv_expr (se, expr);
4142 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4143 gfc_add_modify (&se->pre, var, se->expr);
4144 gfc_add_block_to_block (&se->pre, &se->post);
4150 if (expr->expr_type == EXPR_FUNCTION
4151 && expr->symtree->n.sym->attr.pointer
4152 && !expr->symtree->n.sym->attr.dimension)
4154 se->want_pointer = 1;
4155 gfc_conv_expr (se, expr);
4156 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4157 gfc_add_modify (&se->pre, var, se->expr);
4163 gfc_conv_expr (se, expr);
4165 /* Create a temporary var to hold the value. */
4166 if (TREE_CONSTANT (se->expr))
4168 tree tmp = se->expr;
4169 STRIP_TYPE_NOPS (tmp);
4170 var = build_decl (input_location,
4171 CONST_DECL, NULL, TREE_TYPE (tmp));
4172 DECL_INITIAL (var) = tmp;
4173 TREE_STATIC (var) = 1;
4178 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4179 gfc_add_modify (&se->pre, var, se->expr);
4181 gfc_add_block_to_block (&se->pre, &se->post);
4183 /* Take the address of that value. */
4184 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4189 gfc_trans_pointer_assign (gfc_code * code)
4191 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4195 /* Generate code for a pointer assignment. */
4198 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4209 gfc_start_block (&block);
4211 gfc_init_se (&lse, NULL);
4213 lss = gfc_walk_expr (expr1);
4214 rss = gfc_walk_expr (expr2);
4215 if (lss == gfc_ss_terminator)
4217 /* Scalar pointers. */
4218 lse.want_pointer = 1;
4219 gfc_conv_expr (&lse, expr1);
4220 gcc_assert (rss == gfc_ss_terminator);
4221 gfc_init_se (&rse, NULL);
4222 rse.want_pointer = 1;
4223 gfc_conv_expr (&rse, expr2);
4225 if (expr1->symtree->n.sym->attr.proc_pointer
4226 && expr1->symtree->n.sym->attr.dummy)
4227 lse.expr = build_fold_indirect_ref_loc (input_location,
4230 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4231 && expr2->symtree->n.sym->attr.dummy)
4232 rse.expr = build_fold_indirect_ref_loc (input_location,
4235 gfc_add_block_to_block (&block, &lse.pre);
4236 gfc_add_block_to_block (&block, &rse.pre);
4238 /* Check character lengths if character expression. The test is only
4239 really added if -fbounds-check is enabled. */
4240 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4242 gcc_assert (expr2->ts.type == BT_CHARACTER);
4243 gcc_assert (lse.string_length && rse.string_length);
4244 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4245 lse.string_length, rse.string_length,
4249 gfc_add_modify (&block, lse.expr,
4250 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4252 gfc_add_block_to_block (&block, &rse.post);
4253 gfc_add_block_to_block (&block, &lse.post);
4258 tree strlen_rhs = NULL_TREE;
4260 /* Array pointer. */
4261 gfc_conv_expr_descriptor (&lse, expr1, lss);
4262 strlen_lhs = lse.string_length;
4263 switch (expr2->expr_type)
4266 /* Just set the data pointer to null. */
4267 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4271 /* Assign directly to the pointer's descriptor. */
4272 lse.direct_byref = 1;
4273 gfc_conv_expr_descriptor (&lse, expr2, rss);
4274 strlen_rhs = lse.string_length;
4276 /* If this is a subreference array pointer assignment, use the rhs
4277 descriptor element size for the lhs span. */
4278 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4280 decl = expr1->symtree->n.sym->backend_decl;
4281 gfc_init_se (&rse, NULL);
4282 rse.descriptor_only = 1;
4283 gfc_conv_expr (&rse, expr2);
4284 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4285 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4286 if (!INTEGER_CST_P (tmp))
4287 gfc_add_block_to_block (&lse.post, &rse.pre);
4288 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4294 /* Assign to a temporary descriptor and then copy that
4295 temporary to the pointer. */
4297 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4300 lse.direct_byref = 1;
4301 gfc_conv_expr_descriptor (&lse, expr2, rss);
4302 strlen_rhs = lse.string_length;
4303 gfc_add_modify (&lse.pre, desc, tmp);
4307 gfc_add_block_to_block (&block, &lse.pre);
4309 /* Check string lengths if applicable. The check is only really added
4310 to the output code if -fbounds-check is enabled. */
4311 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4313 gcc_assert (expr2->ts.type == BT_CHARACTER);
4314 gcc_assert (strlen_lhs && strlen_rhs);
4315 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4316 strlen_lhs, strlen_rhs, &block);
4319 gfc_add_block_to_block (&block, &lse.post);
4321 return gfc_finish_block (&block);
4325 /* Makes sure se is suitable for passing as a function string parameter. */
4326 /* TODO: Need to check all callers of this function. It may be abused. */
4329 gfc_conv_string_parameter (gfc_se * se)
4333 if (TREE_CODE (se->expr) == STRING_CST)
4335 type = TREE_TYPE (TREE_TYPE (se->expr));
4336 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4340 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4342 if (TREE_CODE (se->expr) != INDIRECT_REF)
4344 type = TREE_TYPE (se->expr);
4345 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4349 type = gfc_get_character_type_len (gfc_default_character_kind,
4351 type = build_pointer_type (type);
4352 se->expr = gfc_build_addr_expr (type, se->expr);
4356 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4357 gcc_assert (se->string_length
4358 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4362 /* Generate code for assignment of scalar variables. Includes character
4363 strings and derived types with allocatable components. */
4366 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4367 bool l_is_temp, bool r_is_var)
4373 gfc_init_block (&block);
4375 if (ts.type == BT_CHARACTER)
4380 if (lse->string_length != NULL_TREE)
4382 gfc_conv_string_parameter (lse);
4383 gfc_add_block_to_block (&block, &lse->pre);
4384 llen = lse->string_length;
4387 if (rse->string_length != NULL_TREE)
4389 gcc_assert (rse->string_length != NULL_TREE);
4390 gfc_conv_string_parameter (rse);
4391 gfc_add_block_to_block (&block, &rse->pre);
4392 rlen = rse->string_length;
4395 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4396 rse->expr, ts.kind);
4398 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4402 /* Are the rhs and the lhs the same? */
4405 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4406 gfc_build_addr_expr (NULL_TREE, lse->expr),
4407 gfc_build_addr_expr (NULL_TREE, rse->expr));
4408 cond = gfc_evaluate_now (cond, &lse->pre);
4411 /* Deallocate the lhs allocated components as long as it is not
4412 the same as the rhs. This must be done following the assignment
4413 to prevent deallocating data that could be used in the rhs
4417 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4418 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4420 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4422 gfc_add_expr_to_block (&lse->post, tmp);
4425 gfc_add_block_to_block (&block, &rse->pre);
4426 gfc_add_block_to_block (&block, &lse->pre);
4428 gfc_add_modify (&block, lse->expr,
4429 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4431 /* Do a deep copy if the rhs is a variable, if it is not the
4435 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4436 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4438 gfc_add_expr_to_block (&block, tmp);
4441 else if (ts.type == BT_DERIVED)
4443 gfc_add_block_to_block (&block, &lse->pre);
4444 gfc_add_block_to_block (&block, &rse->pre);
4445 tmp = gfc_evaluate_now (rse->expr, &block);
4446 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4447 gfc_add_modify (&block, lse->expr, tmp);
4451 gfc_add_block_to_block (&block, &lse->pre);
4452 gfc_add_block_to_block (&block, &rse->pre);
4454 gfc_add_modify (&block, lse->expr,
4455 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4458 gfc_add_block_to_block (&block, &lse->post);
4459 gfc_add_block_to_block (&block, &rse->post);
4461 return gfc_finish_block (&block);
4465 /* Try to translate array(:) = func (...), where func is a transformational
4466 array function, without using a temporary. Returns NULL is this isn't the
4470 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4475 bool seen_array_ref;
4477 gfc_component *comp = NULL;
4479 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4480 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4483 /* Elemental functions don't need a temporary anyway. */
4484 if (expr2->value.function.esym != NULL
4485 && expr2->value.function.esym->attr.elemental)
4488 /* Fail if rhs is not FULL or a contiguous section. */
4489 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4492 /* Fail if EXPR1 can't be expressed as a descriptor. */
4493 if (gfc_ref_needs_temporary_p (expr1->ref))
4496 /* Functions returning pointers need temporaries. */
4497 if (expr2->symtree->n.sym->attr.pointer
4498 || expr2->symtree->n.sym->attr.allocatable)
4501 /* Character array functions need temporaries unless the
4502 character lengths are the same. */
4503 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4505 if (expr1->ts.u.cl->length == NULL
4506 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4509 if (expr2->ts.u.cl->length == NULL
4510 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4513 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4514 expr2->ts.u.cl->length->value.integer) != 0)
4518 /* Check that no LHS component references appear during an array
4519 reference. This is needed because we do not have the means to
4520 span any arbitrary stride with an array descriptor. This check
4521 is not needed for the rhs because the function result has to be
4523 seen_array_ref = false;
4524 for (ref = expr1->ref; ref; ref = ref->next)
4526 if (ref->type == REF_ARRAY)
4527 seen_array_ref= true;
4528 else if (ref->type == REF_COMPONENT && seen_array_ref)
4532 /* Check for a dependency. */
4533 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4534 expr2->value.function.esym,
4535 expr2->value.function.actual,
4539 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4541 gcc_assert (expr2->value.function.isym
4542 || (gfc_is_proc_ptr_comp (expr2, &comp)
4543 && comp && comp->attr.dimension)
4544 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
4545 && expr2->value.function.esym->result->attr.dimension));
4547 ss = gfc_walk_expr (expr1);
4548 gcc_assert (ss != gfc_ss_terminator);
4549 gfc_init_se (&se, NULL);
4550 gfc_start_block (&se.pre);
4551 se.want_pointer = 1;
4553 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
4555 se.direct_byref = 1;
4556 se.ss = gfc_walk_expr (expr2);
4557 gcc_assert (se.ss != gfc_ss_terminator);
4558 gfc_conv_function_expr (&se, expr2);
4559 gfc_add_block_to_block (&se.pre, &se.post);
4561 return gfc_finish_block (&se.pre);
4564 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4567 is_zero_initializer_p (gfc_expr * expr)
4569 if (expr->expr_type != EXPR_CONSTANT)
4572 /* We ignore constants with prescribed memory representations for now. */
4573 if (expr->representation.string)
4576 switch (expr->ts.type)
4579 return mpz_cmp_si (expr->value.integer, 0) == 0;
4582 return mpfr_zero_p (expr->value.real)
4583 && MPFR_SIGN (expr->value.real) >= 0;
4586 return expr->value.logical == 0;
4589 return mpfr_zero_p (mpc_realref (expr->value.complex))
4590 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4591 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4592 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4600 /* Try to efficiently translate array(:) = 0. Return NULL if this
4604 gfc_trans_zero_assign (gfc_expr * expr)
4606 tree dest, len, type;
4610 sym = expr->symtree->n.sym;
4611 dest = gfc_get_symbol_decl (sym);
4613 type = TREE_TYPE (dest);
4614 if (POINTER_TYPE_P (type))
4615 type = TREE_TYPE (type);
4616 if (!GFC_ARRAY_TYPE_P (type))
4619 /* Determine the length of the array. */
4620 len = GFC_TYPE_ARRAY_SIZE (type);
4621 if (!len || TREE_CODE (len) != INTEGER_CST)
4624 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4625 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4626 fold_convert (gfc_array_index_type, tmp));
4628 /* If we are zeroing a local array avoid taking its address by emitting
4630 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4631 return build2 (MODIFY_EXPR, void_type_node,
4632 dest, build_constructor (TREE_TYPE (dest), NULL));
4634 /* Convert arguments to the correct types. */
4635 dest = fold_convert (pvoid_type_node, dest);
4636 len = fold_convert (size_type_node, len);
4638 /* Construct call to __builtin_memset. */
4639 tmp = build_call_expr_loc (input_location,
4640 built_in_decls[BUILT_IN_MEMSET],
4641 3, dest, integer_zero_node, len);
4642 return fold_convert (void_type_node, tmp);
4646 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4647 that constructs the call to __builtin_memcpy. */
4650 gfc_build_memcpy_call (tree dst, tree src, tree len)
4654 /* Convert arguments to the correct types. */
4655 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4656 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4658 dst = fold_convert (pvoid_type_node, dst);
4660 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4661 src = gfc_build_addr_expr (pvoid_type_node, src);
4663 src = fold_convert (pvoid_type_node, src);
4665 len = fold_convert (size_type_node, len);
4667 /* Construct call to __builtin_memcpy. */
4668 tmp = build_call_expr_loc (input_location,
4669 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4670 return fold_convert (void_type_node, tmp);
4674 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4675 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4676 source/rhs, both are gfc_full_array_ref_p which have been checked for
4680 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4682 tree dst, dlen, dtype;
4683 tree src, slen, stype;
4686 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4687 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4689 dtype = TREE_TYPE (dst);
4690 if (POINTER_TYPE_P (dtype))
4691 dtype = TREE_TYPE (dtype);
4692 stype = TREE_TYPE (src);
4693 if (POINTER_TYPE_P (stype))
4694 stype = TREE_TYPE (stype);
4696 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4699 /* Determine the lengths of the arrays. */
4700 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4701 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4703 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4704 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4705 fold_convert (gfc_array_index_type, tmp));
4707 slen = GFC_TYPE_ARRAY_SIZE (stype);
4708 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4710 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4711 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4712 fold_convert (gfc_array_index_type, tmp));
4714 /* Sanity check that they are the same. This should always be
4715 the case, as we should already have checked for conformance. */
4716 if (!tree_int_cst_equal (slen, dlen))
4719 return gfc_build_memcpy_call (dst, src, dlen);
4723 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4724 this can't be done. EXPR1 is the destination/lhs for which
4725 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4728 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4730 unsigned HOST_WIDE_INT nelem;
4736 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4740 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4741 dtype = TREE_TYPE (dst);
4742 if (POINTER_TYPE_P (dtype))
4743 dtype = TREE_TYPE (dtype);
4744 if (!GFC_ARRAY_TYPE_P (dtype))
4747 /* Determine the lengths of the array. */
4748 len = GFC_TYPE_ARRAY_SIZE (dtype);
4749 if (!len || TREE_CODE (len) != INTEGER_CST)
4752 /* Confirm that the constructor is the same size. */
4753 if (compare_tree_int (len, nelem) != 0)
4756 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4757 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4758 fold_convert (gfc_array_index_type, tmp));
4760 stype = gfc_typenode_for_spec (&expr2->ts);
4761 src = gfc_build_constant_array_constructor (expr2, stype);
4763 stype = TREE_TYPE (src);
4764 if (POINTER_TYPE_P (stype))
4765 stype = TREE_TYPE (stype);
4767 return gfc_build_memcpy_call (dst, src, len);
4771 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4772 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4775 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4780 gfc_ss *lss_section;
4787 bool scalar_to_array;
4790 /* Assignment of the form lhs = rhs. */
4791 gfc_start_block (&block);
4793 gfc_init_se (&lse, NULL);
4794 gfc_init_se (&rse, NULL);
4797 lss = gfc_walk_expr (expr1);
4799 if (lss != gfc_ss_terminator)
4801 /* Allow the scalarizer to workshare array assignments. */
4802 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4803 ompws_flags |= OMPWS_SCALARIZER_WS;
4805 /* The assignment needs scalarization. */
4808 /* Find a non-scalar SS from the lhs. */
4809 while (lss_section != gfc_ss_terminator
4810 && lss_section->type != GFC_SS_SECTION)
4811 lss_section = lss_section->next;
4813 gcc_assert (lss_section != gfc_ss_terminator);
4815 /* Initialize the scalarizer. */
4816 gfc_init_loopinfo (&loop);
4819 rss = gfc_walk_expr (expr2);
4820 if (rss == gfc_ss_terminator)
4822 /* The rhs is scalar. Add a ss for the expression. */
4823 rss = gfc_get_ss ();
4824 rss->next = gfc_ss_terminator;
4825 rss->type = GFC_SS_SCALAR;
4828 /* Associate the SS with the loop. */
4829 gfc_add_ss_to_loop (&loop, lss);
4830 gfc_add_ss_to_loop (&loop, rss);
4832 /* Calculate the bounds of the scalarization. */
4833 gfc_conv_ss_startstride (&loop);
4834 /* Resolve any data dependencies in the statement. */
4835 gfc_conv_resolve_dependencies (&loop, lss, rss);
4836 /* Setup the scalarizing loops. */
4837 gfc_conv_loop_setup (&loop, &expr2->where);
4839 /* Setup the gfc_se structures. */
4840 gfc_copy_loopinfo_to_se (&lse, &loop);
4841 gfc_copy_loopinfo_to_se (&rse, &loop);
4844 gfc_mark_ss_chain_used (rss, 1);
4845 if (loop.temp_ss == NULL)
4848 gfc_mark_ss_chain_used (lss, 1);
4852 lse.ss = loop.temp_ss;
4853 gfc_mark_ss_chain_used (lss, 3);
4854 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4857 /* Start the scalarized loop body. */
4858 gfc_start_scalarized_body (&loop, &body);
4861 gfc_init_block (&body);
4863 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4865 /* Translate the expression. */
4866 gfc_conv_expr (&rse, expr2);
4868 /* Stabilize a string length for temporaries. */
4869 if (expr2->ts.type == BT_CHARACTER)
4870 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
4872 string_length = NULL_TREE;
4876 gfc_conv_tmp_array_ref (&lse);
4877 gfc_advance_se_ss_chain (&lse);
4878 if (expr2->ts.type == BT_CHARACTER)
4879 lse.string_length = string_length;
4882 gfc_conv_expr (&lse, expr1);
4884 /* Assignments of scalar derived types with allocatable components
4885 to arrays must be done with a deep copy and the rhs temporary
4886 must have its components deallocated afterwards. */
4887 scalar_to_array = (expr2->ts.type == BT_DERIVED
4888 && expr2->ts.u.derived->attr.alloc_comp
4889 && expr2->expr_type != EXPR_VARIABLE
4890 && !gfc_is_constant_expr (expr2)
4891 && expr1->rank && !expr2->rank);
4892 if (scalar_to_array)
4894 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
4895 gfc_add_expr_to_block (&loop.post, tmp);
4898 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4899 l_is_temp || init_flag,
4900 (expr2->expr_type == EXPR_VARIABLE)
4901 || scalar_to_array);
4902 gfc_add_expr_to_block (&body, tmp);
4904 if (lss == gfc_ss_terminator)
4906 /* Use the scalar assignment as is. */
4907 gfc_add_block_to_block (&block, &body);
4911 gcc_assert (lse.ss == gfc_ss_terminator
4912 && rse.ss == gfc_ss_terminator);
4916 gfc_trans_scalarized_loop_boundary (&loop, &body);
4918 /* We need to copy the temporary to the actual lhs. */
4919 gfc_init_se (&lse, NULL);
4920 gfc_init_se (&rse, NULL);
4921 gfc_copy_loopinfo_to_se (&lse, &loop);
4922 gfc_copy_loopinfo_to_se (&rse, &loop);
4924 rse.ss = loop.temp_ss;
4927 gfc_conv_tmp_array_ref (&rse);
4928 gfc_advance_se_ss_chain (&rse);
4929 gfc_conv_expr (&lse, expr1);
4931 gcc_assert (lse.ss == gfc_ss_terminator
4932 && rse.ss == gfc_ss_terminator);
4934 if (expr2->ts.type == BT_CHARACTER)
4935 rse.string_length = string_length;
4937 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4939 gfc_add_expr_to_block (&body, tmp);
4942 /* Generate the copying loops. */
4943 gfc_trans_scalarizing_loops (&loop, &body);
4945 /* Wrap the whole thing up. */
4946 gfc_add_block_to_block (&block, &loop.pre);
4947 gfc_add_block_to_block (&block, &loop.post);
4949 gfc_cleanup_loop (&loop);
4952 return gfc_finish_block (&block);
4956 /* Check whether EXPR is a copyable array. */
4959 copyable_array_p (gfc_expr * expr)
4961 if (expr->expr_type != EXPR_VARIABLE)
4964 /* First check it's an array. */
4965 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4968 if (!gfc_full_array_ref_p (expr->ref, NULL))
4971 /* Next check that it's of a simple enough type. */
4972 switch (expr->ts.type)
4984 return !expr->ts.u.derived->attr.alloc_comp;
4993 /* Translate an assignment. */
4996 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5000 /* Special case a single function returning an array. */
5001 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5003 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5008 /* Special case assigning an array to zero. */
5009 if (copyable_array_p (expr1)
5010 && is_zero_initializer_p (expr2))
5012 tmp = gfc_trans_zero_assign (expr1);
5017 /* Special case copying one array to another. */
5018 if (copyable_array_p (expr1)
5019 && copyable_array_p (expr2)
5020 && gfc_compare_types (&expr1->ts, &expr2->ts)
5021 && !gfc_check_dependency (expr1, expr2, 0))
5023 tmp = gfc_trans_array_copy (expr1, expr2);
5028 /* Special case initializing an array from a constant array constructor. */
5029 if (copyable_array_p (expr1)
5030 && expr2->expr_type == EXPR_ARRAY
5031 && gfc_compare_types (&expr1->ts, &expr2->ts))
5033 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5038 /* Fallback to the scalarizer to generate explicit loops. */
5039 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
5043 gfc_trans_init_assign (gfc_code * code)
5045 return gfc_trans_assignment (code->expr1, code->expr2, true);
5049 gfc_trans_assign (gfc_code * code)
5051 return gfc_trans_assignment (code->expr1, code->expr2, false);