1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (CONSTANT_CLASS_P (se->expr))
113 /* We need a temporary for this result. */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 gcc_assert (sym->attr.dummy);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
139 return fold_build2 (NE_EXPR, boolean_type_node, decl,
140 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Converts a missing, dummy argument into a null or zero. */
147 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
152 present = gfc_conv_expr_present (arg->symtree->n.sym);
156 /* Create a temporary and convert it to the correct type. */
157 tmp = gfc_get_int_type (kind);
158 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
161 /* Test for a NULL value. */
162 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
163 fold_convert (TREE_TYPE (tmp), integer_one_node));
164 tmp = gfc_evaluate_now (tmp, &se->pre);
165 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
169 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
170 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
171 tmp = gfc_evaluate_now (tmp, &se->pre);
175 if (ts.type == BT_CHARACTER)
177 tmp = build_int_cst (gfc_charlen_type_node, 0);
178 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
179 present, se->string_length, tmp);
180 tmp = gfc_evaluate_now (tmp, &se->pre);
181 se->string_length = tmp;
187 /* Get the character length of an expression, looking through gfc_refs
191 gfc_get_expr_charlen (gfc_expr *e)
196 gcc_assert (e->expr_type == EXPR_VARIABLE
197 && e->ts.type == BT_CHARACTER);
199 length = NULL; /* To silence compiler warning. */
201 if (is_subref_array (e) && e->ts.u.cl->length)
204 gfc_init_se (&tmpse, NULL);
205 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
206 e->ts.u.cl->backend_decl = tmpse.expr;
210 /* First candidate: if the variable is of type CHARACTER, the
211 expression's length could be the length of the character
213 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
214 length = e->symtree->n.sym->ts.u.cl->backend_decl;
216 /* Look through the reference chain for component references. */
217 for (r = e->ref; r; r = r->next)
222 if (r->u.c.component->ts.type == BT_CHARACTER)
223 length = r->u.c.component->ts.u.cl->backend_decl;
231 /* We should never got substring references here. These will be
232 broken down by the scalarizer. */
238 gcc_assert (length != NULL);
243 /* For each character array constructor subexpression without a ts.u.cl->length,
244 replace it by its first element (if there aren't any elements, the length
245 should already be set to zero). */
248 flatten_array_ctors_without_strlen (gfc_expr* e)
250 gfc_actual_arglist* arg;
256 switch (e->expr_type)
260 flatten_array_ctors_without_strlen (e->value.op.op1);
261 flatten_array_ctors_without_strlen (e->value.op.op2);
265 /* TODO: Implement as with EXPR_FUNCTION when needed. */
269 for (arg = e->value.function.actual; arg; arg = arg->next)
270 flatten_array_ctors_without_strlen (arg->expr);
275 /* We've found what we're looking for. */
276 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
281 gcc_assert (e->value.constructor);
283 c = gfc_constructor_first (e->value.constructor);
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 = gfc_constructor_first (e->value.constructor);
295 c; c = gfc_constructor_next (c))
296 flatten_array_ctors_without_strlen (c->expr);
306 /* Generate code to initialize a string length variable. Returns the
307 value. For array constructors, cl->length might be NULL and in this case,
308 the first element of the constructor is needed. expr is the original
309 expression so we can access it but can be NULL if this is not needed. */
312 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
316 gfc_init_se (&se, NULL);
318 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
319 "flatten" array constructors by taking their first element; all elements
320 should be the same length or a cl->length should be present. */
326 expr_flat = gfc_copy_expr (expr);
327 flatten_array_ctors_without_strlen (expr_flat);
328 gfc_resolve_expr (expr_flat);
330 gfc_conv_expr (&se, expr_flat);
331 gfc_add_block_to_block (pblock, &se.pre);
332 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
334 gfc_free_expr (expr_flat);
338 /* Convert cl->length. */
340 gcc_assert (cl->length);
342 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
343 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
344 build_int_cst (gfc_charlen_type_node, 0));
345 gfc_add_block_to_block (pblock, &se.pre);
347 if (cl->backend_decl)
348 gfc_add_modify (pblock, cl->backend_decl, se.expr);
350 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
355 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
356 const char *name, locus *where)
365 type = gfc_get_character_type (kind, ref->u.ss.length);
366 type = build_pointer_type (type);
368 gfc_init_se (&start, se);
369 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
370 gfc_add_block_to_block (&se->pre, &start.pre);
372 if (integer_onep (start.expr))
373 gfc_conv_string_parameter (se);
378 /* Avoid multiple evaluation of substring start. */
379 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
380 start.expr = gfc_evaluate_now (start.expr, &se->pre);
382 /* Change the start of the string. */
383 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
386 tmp = build_fold_indirect_ref_loc (input_location,
388 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
389 se->expr = gfc_build_addr_expr (type, tmp);
392 /* Length = end + 1 - start. */
393 gfc_init_se (&end, se);
394 if (ref->u.ss.end == NULL)
395 end.expr = se->string_length;
398 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
399 gfc_add_block_to_block (&se->pre, &end.pre);
403 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
404 end.expr = gfc_evaluate_now (end.expr, &se->pre);
406 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
408 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
409 start.expr, end.expr);
411 /* Check lower bound. */
412 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
413 build_int_cst (gfc_charlen_type_node, 1));
414 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
417 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
418 "is less than one", name);
420 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
422 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
423 fold_convert (long_integer_type_node,
427 /* Check upper bound. */
428 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
430 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
433 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
434 "exceeds string length (%%ld)", name);
436 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
437 "exceeds string length (%%ld)");
438 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
439 fold_convert (long_integer_type_node, end.expr),
440 fold_convert (long_integer_type_node,
445 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
446 end.expr, start.expr);
447 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
448 build_int_cst (gfc_charlen_type_node, 1), tmp);
449 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
450 build_int_cst (gfc_charlen_type_node, 0));
451 se->string_length = tmp;
455 /* Convert a derived type component reference. */
458 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
465 c = ref->u.c.component;
467 gcc_assert (c->backend_decl);
469 field = c->backend_decl;
470 gcc_assert (TREE_CODE (field) == FIELD_DECL);
472 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
476 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
478 tmp = c->ts.u.cl->backend_decl;
479 /* Components must always be constant length. */
480 gcc_assert (tmp && INTEGER_CST_P (tmp));
481 se->string_length = tmp;
484 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
485 && 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->backend_decl == NULL)
512 gfc_get_derived_type (dt);
514 if (dt->attr.extension && dt->components)
516 if (dt->attr.is_class)
517 cmp = dt->components;
519 cmp = dt->components->next;
520 /* Return if the component is not in the parent type. */
521 for (; cmp; cmp = cmp->next)
522 if (strcmp (c->name, cmp->name) == 0)
525 /* Otherwise build the reference and call self. */
526 gfc_conv_component_ref (se, &parent);
527 parent.u.c.sym = dt->components->ts.u.derived;
528 parent.u.c.component = c;
529 conv_parent_component_references (se, &parent);
533 /* Return the contents of a variable. Also handles reference/pointer
534 variables (all Fortran pointer references are implicit). */
537 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
544 bool alternate_entry;
547 sym = expr->symtree->n.sym;
550 /* Check that something hasn't gone horribly wrong. */
551 gcc_assert (se->ss != gfc_ss_terminator);
552 gcc_assert (se->ss->expr == expr);
554 /* A scalarized term. We already know the descriptor. */
555 se->expr = se->ss->data.info.descriptor;
556 se->string_length = se->ss->string_length;
557 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
558 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
563 tree se_expr = NULL_TREE;
565 se->expr = gfc_get_symbol_decl (sym);
567 /* Deal with references to a parent results or entries by storing
568 the current_function_decl and moving to the parent_decl. */
569 return_value = sym->attr.function && sym->result == sym;
570 alternate_entry = sym->attr.function && sym->attr.entry
571 && sym->result == sym;
572 entry_master = sym->attr.result
573 && sym->ns->proc_name->attr.entry_master
574 && !gfc_return_by_reference (sym->ns->proc_name);
575 parent_decl = DECL_CONTEXT (current_function_decl);
577 if ((se->expr == parent_decl && return_value)
578 || (sym->ns && sym->ns->proc_name
580 && sym->ns->proc_name->backend_decl == parent_decl
581 && (alternate_entry || entry_master)))
586 /* Special case for assigning the return value of a function.
587 Self recursive functions must have an explicit return value. */
588 if (return_value && (se->expr == current_function_decl || parent_flag))
589 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
591 /* Similarly for alternate entry points. */
592 else if (alternate_entry
593 && (sym->ns->proc_name->backend_decl == current_function_decl
596 gfc_entry_list *el = NULL;
598 for (el = sym->ns->entries; el; el = el->next)
601 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
606 else if (entry_master
607 && (sym->ns->proc_name->backend_decl == current_function_decl
609 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
614 /* Procedure actual arguments. */
615 else if (sym->attr.flavor == FL_PROCEDURE
616 && se->expr != current_function_decl)
618 if (!sym->attr.dummy && !sym->attr.proc_pointer)
620 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
621 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
627 /* Dereference the expression, where needed. Since characters
628 are entirely different from other types, they are treated
630 if (sym->ts.type == BT_CHARACTER)
632 /* Dereference character pointer dummy arguments
634 if ((sym->attr.pointer || sym->attr.allocatable)
636 || sym->attr.function
637 || sym->attr.result))
638 se->expr = build_fold_indirect_ref_loc (input_location,
642 else if (!sym->attr.value)
644 /* Dereference non-character scalar dummy arguments. */
645 if (sym->attr.dummy && !sym->attr.dimension)
646 se->expr = build_fold_indirect_ref_loc (input_location,
649 /* Dereference scalar hidden result. */
650 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
651 && (sym->attr.function || sym->attr.result)
652 && !sym->attr.dimension && !sym->attr.pointer
653 && !sym->attr.always_explicit)
654 se->expr = build_fold_indirect_ref_loc (input_location,
657 /* Dereference non-character pointer variables.
658 These must be dummies, results, or scalars. */
659 if ((sym->attr.pointer || sym->attr.allocatable)
661 || sym->attr.function
663 || !sym->attr.dimension))
664 se->expr = build_fold_indirect_ref_loc (input_location,
671 /* For character variables, also get the length. */
672 if (sym->ts.type == BT_CHARACTER)
674 /* If the character length of an entry isn't set, get the length from
675 the master function instead. */
676 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
677 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
679 se->string_length = sym->ts.u.cl->backend_decl;
680 gcc_assert (se->string_length);
688 /* Return the descriptor if that's what we want and this is an array
689 section reference. */
690 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
692 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
693 /* Return the descriptor for array pointers and allocations. */
695 && ref->next == NULL && (se->descriptor_only))
698 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
699 /* Return a pointer to an element. */
703 if (ref->u.c.sym->attr.extension)
704 conv_parent_component_references (se, ref);
706 gfc_conv_component_ref (se, ref);
710 gfc_conv_substring (se, ref, expr->ts.kind,
711 expr->symtree->name, &expr->where);
720 /* Pointer assignment, allocation or pass by reference. Arrays are handled
722 if (se->want_pointer)
724 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
725 gfc_conv_string_parameter (se);
727 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
732 /* Unary ops are easy... Or they would be if ! was a valid op. */
735 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
740 gcc_assert (expr->ts.type != BT_CHARACTER);
741 /* Initialize the operand. */
742 gfc_init_se (&operand, se);
743 gfc_conv_expr_val (&operand, expr->value.op.op1);
744 gfc_add_block_to_block (&se->pre, &operand.pre);
746 type = gfc_typenode_for_spec (&expr->ts);
748 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
749 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
750 All other unary operators have an equivalent GIMPLE unary operator. */
751 if (code == TRUTH_NOT_EXPR)
752 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
753 build_int_cst (type, 0));
755 se->expr = fold_build1 (code, type, operand.expr);
759 /* Expand power operator to optimal multiplications when a value is raised
760 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
761 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
762 Programming", 3rd Edition, 1998. */
764 /* This code is mostly duplicated from expand_powi in the backend.
765 We establish the "optimal power tree" lookup table with the defined size.
766 The items in the table are the exponents used to calculate the index
767 exponents. Any integer n less than the value can get an "addition chain",
768 with the first node being one. */
769 #define POWI_TABLE_SIZE 256
771 /* The table is from builtins.c. */
772 static const unsigned char powi_table[POWI_TABLE_SIZE] =
774 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
775 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
776 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
777 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
778 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
779 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
780 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
781 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
782 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
783 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
784 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
785 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
786 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
787 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
788 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
789 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
790 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
791 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
792 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
793 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
794 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
795 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
796 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
797 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
798 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
799 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
800 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
801 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
802 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
803 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
804 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
805 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
808 /* If n is larger than lookup table's max index, we use the "window
810 #define POWI_WINDOW_SIZE 3
812 /* Recursive function to expand the power operator. The temporary
813 values are put in tmpvar. The function returns tmpvar[1] ** n. */
815 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
822 if (n < POWI_TABLE_SIZE)
827 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
828 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
832 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
833 op0 = gfc_conv_powi (se, n - digit, tmpvar);
834 op1 = gfc_conv_powi (se, digit, tmpvar);
838 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
842 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
843 tmp = gfc_evaluate_now (tmp, &se->pre);
845 if (n < POWI_TABLE_SIZE)
852 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
853 return 1. Else return 0 and a call to runtime library functions
854 will have to be built. */
856 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
861 tree vartmp[POWI_TABLE_SIZE];
863 unsigned HOST_WIDE_INT n;
866 /* If exponent is too large, we won't expand it anyway, so don't bother
867 with large integer values. */
868 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
871 m = double_int_to_shwi (TREE_INT_CST (rhs));
872 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
873 of the asymmetric range of the integer type. */
874 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
876 type = TREE_TYPE (lhs);
877 sgn = tree_int_cst_sgn (rhs);
879 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
880 || optimize_size) && (m > 2 || m < -1))
886 se->expr = gfc_build_const (type, integer_one_node);
890 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
891 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
893 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
894 lhs, build_int_cst (TREE_TYPE (lhs), -1));
895 cond = fold_build2 (EQ_EXPR, boolean_type_node,
896 lhs, build_int_cst (TREE_TYPE (lhs), 1));
899 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
902 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
903 se->expr = fold_build3 (COND_EXPR, type,
904 tmp, build_int_cst (type, 1),
905 build_int_cst (type, 0));
909 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
910 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
911 build_int_cst (type, 0));
912 se->expr = fold_build3 (COND_EXPR, type,
913 cond, build_int_cst (type, 1), tmp);
917 memset (vartmp, 0, sizeof (vartmp));
921 tmp = gfc_build_const (type, integer_one_node);
922 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
925 se->expr = gfc_conv_powi (se, n, vartmp);
931 /* Power op (**). Constant integer exponent has special handling. */
934 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
936 tree gfc_int4_type_node;
943 gfc_init_se (&lse, se);
944 gfc_conv_expr_val (&lse, expr->value.op.op1);
945 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
946 gfc_add_block_to_block (&se->pre, &lse.pre);
948 gfc_init_se (&rse, se);
949 gfc_conv_expr_val (&rse, expr->value.op.op2);
950 gfc_add_block_to_block (&se->pre, &rse.pre);
952 if (expr->value.op.op2->ts.type == BT_INTEGER
953 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
954 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
957 gfc_int4_type_node = gfc_get_int_type (4);
959 kind = expr->value.op.op1->ts.kind;
960 switch (expr->value.op.op2->ts.type)
963 ikind = expr->value.op.op2->ts.kind;
968 rse.expr = convert (gfc_int4_type_node, rse.expr);
990 if (expr->value.op.op1->ts.type == BT_INTEGER)
991 lse.expr = convert (gfc_int4_type_node, lse.expr);
1016 switch (expr->value.op.op1->ts.type)
1019 if (kind == 3) /* Case 16 was not handled properly above. */
1021 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1025 /* Use builtins for real ** int4. */
1031 fndecl = built_in_decls[BUILT_IN_POWIF];
1035 fndecl = built_in_decls[BUILT_IN_POWI];
1040 fndecl = built_in_decls[BUILT_IN_POWIL];
1048 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1052 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1064 fndecl = built_in_decls[BUILT_IN_POWF];
1067 fndecl = built_in_decls[BUILT_IN_POW];
1071 fndecl = built_in_decls[BUILT_IN_POWL];
1082 fndecl = built_in_decls[BUILT_IN_CPOWF];
1085 fndecl = built_in_decls[BUILT_IN_CPOW];
1089 fndecl = built_in_decls[BUILT_IN_CPOWL];
1101 se->expr = build_call_expr_loc (input_location,
1102 fndecl, 2, lse.expr, rse.expr);
1106 /* Generate code to allocate a string temporary. */
1109 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1114 if (gfc_can_put_var_on_stack (len))
1116 /* Create a temporary variable to hold the result. */
1117 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1118 build_int_cst (gfc_charlen_type_node, 1));
1119 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1121 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1122 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1124 tmp = build_array_type (TREE_TYPE (type), tmp);
1126 var = gfc_create_var (tmp, "str");
1127 var = gfc_build_addr_expr (type, var);
1131 /* Allocate a temporary to hold the result. */
1132 var = gfc_create_var (type, "pstr");
1133 tmp = gfc_call_malloc (&se->pre, type,
1134 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1135 fold_convert (TREE_TYPE (len),
1136 TYPE_SIZE (type))));
1137 gfc_add_modify (&se->pre, var, tmp);
1139 /* Free the temporary afterwards. */
1140 tmp = gfc_call_free (convert (pvoid_type_node, var));
1141 gfc_add_expr_to_block (&se->post, tmp);
1148 /* Handle a string concatenation operation. A temporary will be allocated to
1152 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1155 tree len, type, var, tmp, fndecl;
1157 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1158 && expr->value.op.op2->ts.type == BT_CHARACTER);
1159 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1161 gfc_init_se (&lse, se);
1162 gfc_conv_expr (&lse, expr->value.op.op1);
1163 gfc_conv_string_parameter (&lse);
1164 gfc_init_se (&rse, se);
1165 gfc_conv_expr (&rse, expr->value.op.op2);
1166 gfc_conv_string_parameter (&rse);
1168 gfc_add_block_to_block (&se->pre, &lse.pre);
1169 gfc_add_block_to_block (&se->pre, &rse.pre);
1171 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1172 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1173 if (len == NULL_TREE)
1175 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1176 lse.string_length, rse.string_length);
1179 type = build_pointer_type (type);
1181 var = gfc_conv_string_tmp (se, type, len);
1183 /* Do the actual concatenation. */
1184 if (expr->ts.kind == 1)
1185 fndecl = gfor_fndecl_concat_string;
1186 else if (expr->ts.kind == 4)
1187 fndecl = gfor_fndecl_concat_string_char4;
1191 tmp = build_call_expr_loc (input_location,
1192 fndecl, 6, len, var, lse.string_length, lse.expr,
1193 rse.string_length, rse.expr);
1194 gfc_add_expr_to_block (&se->pre, tmp);
1196 /* Add the cleanup for the operands. */
1197 gfc_add_block_to_block (&se->pre, &rse.post);
1198 gfc_add_block_to_block (&se->pre, &lse.post);
1201 se->string_length = len;
1204 /* Translates an op expression. Common (binary) cases are handled by this
1205 function, others are passed on. Recursion is used in either case.
1206 We use the fact that (op1.ts == op2.ts) (except for the power
1208 Operators need no special handling for scalarized expressions as long as
1209 they call gfc_conv_simple_val to get their operands.
1210 Character strings get special handling. */
1213 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1215 enum tree_code code;
1224 switch (expr->value.op.op)
1226 case INTRINSIC_PARENTHESES:
1227 if ((expr->ts.type == BT_REAL
1228 || expr->ts.type == BT_COMPLEX)
1229 && gfc_option.flag_protect_parens)
1231 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1232 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1237 case INTRINSIC_UPLUS:
1238 gfc_conv_expr (se, expr->value.op.op1);
1241 case INTRINSIC_UMINUS:
1242 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1246 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1249 case INTRINSIC_PLUS:
1253 case INTRINSIC_MINUS:
1257 case INTRINSIC_TIMES:
1261 case INTRINSIC_DIVIDE:
1262 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1263 an integer, we must round towards zero, so we use a
1265 if (expr->ts.type == BT_INTEGER)
1266 code = TRUNC_DIV_EXPR;
1271 case INTRINSIC_POWER:
1272 gfc_conv_power_op (se, expr);
1275 case INTRINSIC_CONCAT:
1276 gfc_conv_concat_op (se, expr);
1280 code = TRUTH_ANDIF_EXPR;
1285 code = TRUTH_ORIF_EXPR;
1289 /* EQV and NEQV only work on logicals, but since we represent them
1290 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1292 case INTRINSIC_EQ_OS:
1300 case INTRINSIC_NE_OS:
1301 case INTRINSIC_NEQV:
1308 case INTRINSIC_GT_OS:
1315 case INTRINSIC_GE_OS:
1322 case INTRINSIC_LT_OS:
1329 case INTRINSIC_LE_OS:
1335 case INTRINSIC_USER:
1336 case INTRINSIC_ASSIGN:
1337 /* These should be converted into function calls by the frontend. */
1341 fatal_error ("Unknown intrinsic op");
1345 /* The only exception to this is **, which is handled separately anyway. */
1346 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1348 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1352 gfc_init_se (&lse, se);
1353 gfc_conv_expr (&lse, expr->value.op.op1);
1354 gfc_add_block_to_block (&se->pre, &lse.pre);
1357 gfc_init_se (&rse, se);
1358 gfc_conv_expr (&rse, expr->value.op.op2);
1359 gfc_add_block_to_block (&se->pre, &rse.pre);
1363 gfc_conv_string_parameter (&lse);
1364 gfc_conv_string_parameter (&rse);
1366 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1367 rse.string_length, rse.expr,
1368 expr->value.op.op1->ts.kind,
1370 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1371 gfc_add_block_to_block (&lse.post, &rse.post);
1374 type = gfc_typenode_for_spec (&expr->ts);
1378 /* The result of logical ops is always boolean_type_node. */
1379 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1380 se->expr = convert (type, tmp);
1383 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1385 /* Add the post blocks. */
1386 gfc_add_block_to_block (&se->post, &rse.post);
1387 gfc_add_block_to_block (&se->post, &lse.post);
1390 /* If a string's length is one, we convert it to a single character. */
1393 gfc_string_to_single_character (tree len, tree str, int kind)
1395 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1397 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1400 if (TREE_INT_CST_LOW (len) == 1)
1402 str = fold_convert (gfc_get_pchar_type (kind), str);
1403 return build_fold_indirect_ref_loc (input_location, str);
1407 && TREE_CODE (str) == ADDR_EXPR
1408 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1409 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1410 && array_ref_low_bound (TREE_OPERAND (str, 0))
1411 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1412 && TREE_INT_CST_LOW (len) > 1
1413 && TREE_INT_CST_LOW (len)
1414 == (unsigned HOST_WIDE_INT)
1415 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1417 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1418 ret = build_fold_indirect_ref_loc (input_location, ret);
1419 if (TREE_CODE (ret) == INTEGER_CST)
1421 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1422 int i, length = TREE_STRING_LENGTH (string_cst);
1423 const char *ptr = TREE_STRING_POINTER (string_cst);
1425 for (i = 1; i < length; i++)
1438 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1441 if (sym->backend_decl)
1443 /* This becomes the nominal_type in
1444 function.c:assign_parm_find_data_types. */
1445 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1446 /* This becomes the passed_type in
1447 function.c:assign_parm_find_data_types. C promotes char to
1448 integer for argument passing. */
1449 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1451 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1456 /* If we have a constant character expression, make it into an
1458 if ((*expr)->expr_type == EXPR_CONSTANT)
1463 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1464 (int)(*expr)->value.character.string[0]);
1465 if ((*expr)->ts.kind != gfc_c_int_kind)
1467 /* The expr needs to be compatible with a C int. If the
1468 conversion fails, then the 2 causes an ICE. */
1469 ts.type = BT_INTEGER;
1470 ts.kind = gfc_c_int_kind;
1471 gfc_convert_type (*expr, &ts, 2);
1474 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1476 if ((*expr)->ref == NULL)
1478 se->expr = gfc_string_to_single_character
1479 (build_int_cst (integer_type_node, 1),
1480 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1482 ((*expr)->symtree->n.sym)),
1487 gfc_conv_variable (se, *expr);
1488 se->expr = gfc_string_to_single_character
1489 (build_int_cst (integer_type_node, 1),
1490 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1498 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1499 if STR is a string literal, otherwise return -1. */
1502 gfc_optimize_len_trim (tree len, tree str, int kind)
1505 && TREE_CODE (str) == ADDR_EXPR
1506 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1507 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1508 && array_ref_low_bound (TREE_OPERAND (str, 0))
1509 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1510 && TREE_INT_CST_LOW (len) >= 1
1511 && TREE_INT_CST_LOW (len)
1512 == (unsigned HOST_WIDE_INT)
1513 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1515 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1516 folded = build_fold_indirect_ref_loc (input_location, folded);
1517 if (TREE_CODE (folded) == INTEGER_CST)
1519 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1520 int length = TREE_STRING_LENGTH (string_cst);
1521 const char *ptr = TREE_STRING_POINTER (string_cst);
1523 for (; length > 0; length--)
1524 if (ptr[length - 1] != ' ')
1533 /* Compare two strings. If they are all single characters, the result is the
1534 subtraction of them. Otherwise, we build a library call. */
1537 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1538 enum tree_code code)
1544 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1545 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1547 sc1 = gfc_string_to_single_character (len1, str1, kind);
1548 sc2 = gfc_string_to_single_character (len2, str2, kind);
1550 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1552 /* Deal with single character specially. */
1553 sc1 = fold_convert (integer_type_node, sc1);
1554 sc2 = fold_convert (integer_type_node, sc2);
1555 return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1558 if ((code == EQ_EXPR || code == NE_EXPR)
1560 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1562 /* If one string is a string literal with LEN_TRIM longer
1563 than the length of the second string, the strings
1565 int len = gfc_optimize_len_trim (len1, str1, kind);
1566 if (len > 0 && compare_tree_int (len2, len) < 0)
1567 return integer_one_node;
1568 len = gfc_optimize_len_trim (len2, str2, kind);
1569 if (len > 0 && compare_tree_int (len1, len) < 0)
1570 return integer_one_node;
1573 /* Build a call for the comparison. */
1575 fndecl = gfor_fndecl_compare_string;
1577 fndecl = gfor_fndecl_compare_string_char4;
1581 return build_call_expr_loc (input_location, fndecl, 4,
1582 len1, str1, len2, str2);
1586 /* Return the backend_decl for a procedure pointer component. */
1589 get_proc_ptr_comp (gfc_expr *e)
1593 gfc_init_se (&comp_se, NULL);
1594 e2 = gfc_copy_expr (e);
1595 e2->expr_type = EXPR_VARIABLE;
1596 gfc_conv_expr (&comp_se, e2);
1598 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1603 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1607 if (gfc_is_proc_ptr_comp (expr, NULL))
1608 tmp = get_proc_ptr_comp (expr);
1609 else if (sym->attr.dummy)
1611 tmp = gfc_get_symbol_decl (sym);
1612 if (sym->attr.proc_pointer)
1613 tmp = build_fold_indirect_ref_loc (input_location,
1615 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1616 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1620 if (!sym->backend_decl)
1621 sym->backend_decl = gfc_get_extern_function_decl (sym);
1623 tmp = sym->backend_decl;
1625 if (sym->attr.cray_pointee)
1627 /* TODO - make the cray pointee a pointer to a procedure,
1628 assign the pointer to it and use it for the call. This
1630 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1631 gfc_get_symbol_decl (sym->cp_pointer));
1632 tmp = gfc_evaluate_now (tmp, &se->pre);
1635 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1637 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1638 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1645 /* Initialize MAPPING. */
1648 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1650 mapping->syms = NULL;
1651 mapping->charlens = NULL;
1655 /* Free all memory held by MAPPING (but not MAPPING itself). */
1658 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1660 gfc_interface_sym_mapping *sym;
1661 gfc_interface_sym_mapping *nextsym;
1663 gfc_charlen *nextcl;
1665 for (sym = mapping->syms; sym; sym = nextsym)
1667 nextsym = sym->next;
1668 sym->new_sym->n.sym->formal = NULL;
1669 gfc_free_symbol (sym->new_sym->n.sym);
1670 gfc_free_expr (sym->expr);
1671 gfc_free (sym->new_sym);
1674 for (cl = mapping->charlens; cl; cl = nextcl)
1677 gfc_free_expr (cl->length);
1683 /* Return a copy of gfc_charlen CL. Add the returned structure to
1684 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1686 static gfc_charlen *
1687 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1690 gfc_charlen *new_charlen;
1692 new_charlen = gfc_get_charlen ();
1693 new_charlen->next = mapping->charlens;
1694 new_charlen->length = gfc_copy_expr (cl->length);
1696 mapping->charlens = new_charlen;
1701 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1702 array variable that can be used as the actual argument for dummy
1703 argument SYM. Add any initialization code to BLOCK. PACKED is as
1704 for gfc_get_nodesc_array_type and DATA points to the first element
1705 in the passed array. */
1708 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1709 gfc_packed packed, tree data)
1714 type = gfc_typenode_for_spec (&sym->ts);
1715 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1716 !sym->attr.target && !sym->attr.pointer
1717 && !sym->attr.proc_pointer);
1719 var = gfc_create_var (type, "ifm");
1720 gfc_add_modify (block, var, fold_convert (type, data));
1726 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1727 and offset of descriptorless array type TYPE given that it has the same
1728 size as DESC. Add any set-up code to BLOCK. */
1731 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1738 offset = gfc_index_zero_node;
1739 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1741 dim = gfc_rank_cst[n];
1742 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1743 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1745 GFC_TYPE_ARRAY_LBOUND (type, n)
1746 = gfc_conv_descriptor_lbound_get (desc, dim);
1747 GFC_TYPE_ARRAY_UBOUND (type, n)
1748 = gfc_conv_descriptor_ubound_get (desc, dim);
1750 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1752 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1753 gfc_conv_descriptor_ubound_get (desc, dim),
1754 gfc_conv_descriptor_lbound_get (desc, dim));
1755 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1756 GFC_TYPE_ARRAY_LBOUND (type, n),
1758 tmp = gfc_evaluate_now (tmp, block);
1759 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1761 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1762 GFC_TYPE_ARRAY_LBOUND (type, n),
1763 GFC_TYPE_ARRAY_STRIDE (type, n));
1764 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1766 offset = gfc_evaluate_now (offset, block);
1767 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1771 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1772 in SE. The caller may still use se->expr and se->string_length after
1773 calling this function. */
1776 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1777 gfc_symbol * sym, gfc_se * se,
1780 gfc_interface_sym_mapping *sm;
1784 gfc_symbol *new_sym;
1786 gfc_symtree *new_symtree;
1788 /* Create a new symbol to represent the actual argument. */
1789 new_sym = gfc_new_symbol (sym->name, NULL);
1790 new_sym->ts = sym->ts;
1791 new_sym->as = gfc_copy_array_spec (sym->as);
1792 new_sym->attr.referenced = 1;
1793 new_sym->attr.dimension = sym->attr.dimension;
1794 new_sym->attr.contiguous = sym->attr.contiguous;
1795 new_sym->attr.codimension = sym->attr.codimension;
1796 new_sym->attr.pointer = sym->attr.pointer;
1797 new_sym->attr.allocatable = sym->attr.allocatable;
1798 new_sym->attr.flavor = sym->attr.flavor;
1799 new_sym->attr.function = sym->attr.function;
1801 /* Ensure that the interface is available and that
1802 descriptors are passed for array actual arguments. */
1803 if (sym->attr.flavor == FL_PROCEDURE)
1805 new_sym->formal = expr->symtree->n.sym->formal;
1806 new_sym->attr.always_explicit
1807 = expr->symtree->n.sym->attr.always_explicit;
1810 /* Create a fake symtree for it. */
1812 new_symtree = gfc_new_symtree (&root, sym->name);
1813 new_symtree->n.sym = new_sym;
1814 gcc_assert (new_symtree == root);
1816 /* Create a dummy->actual mapping. */
1817 sm = XCNEW (gfc_interface_sym_mapping);
1818 sm->next = mapping->syms;
1820 sm->new_sym = new_symtree;
1821 sm->expr = gfc_copy_expr (expr);
1824 /* Stabilize the argument's value. */
1825 if (!sym->attr.function && se)
1826 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1828 if (sym->ts.type == BT_CHARACTER)
1830 /* Create a copy of the dummy argument's length. */
1831 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1832 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1834 /* If the length is specified as "*", record the length that
1835 the caller is passing. We should use the callee's length
1836 in all other cases. */
1837 if (!new_sym->ts.u.cl->length && se)
1839 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1840 new_sym->ts.u.cl->backend_decl = se->string_length;
1847 /* Use the passed value as-is if the argument is a function. */
1848 if (sym->attr.flavor == FL_PROCEDURE)
1851 /* If the argument is either a string or a pointer to a string,
1852 convert it to a boundless character type. */
1853 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1855 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1856 tmp = build_pointer_type (tmp);
1857 if (sym->attr.pointer)
1858 value = build_fold_indirect_ref_loc (input_location,
1862 value = fold_convert (tmp, value);
1865 /* If the argument is a scalar, a pointer to an array or an allocatable,
1867 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1868 value = build_fold_indirect_ref_loc (input_location,
1871 /* For character(*), use the actual argument's descriptor. */
1872 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1873 value = build_fold_indirect_ref_loc (input_location,
1876 /* If the argument is an array descriptor, use it to determine
1877 information about the actual argument's shape. */
1878 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1879 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1881 /* Get the actual argument's descriptor. */
1882 desc = build_fold_indirect_ref_loc (input_location,
1885 /* Create the replacement variable. */
1886 tmp = gfc_conv_descriptor_data_get (desc);
1887 value = gfc_get_interface_mapping_array (&se->pre, sym,
1890 /* Use DESC to work out the upper bounds, strides and offset. */
1891 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1894 /* Otherwise we have a packed array. */
1895 value = gfc_get_interface_mapping_array (&se->pre, sym,
1896 PACKED_FULL, se->expr);
1898 new_sym->backend_decl = value;
1902 /* Called once all dummy argument mappings have been added to MAPPING,
1903 but before the mapping is used to evaluate expressions. Pre-evaluate
1904 the length of each argument, adding any initialization code to PRE and
1905 any finalization code to POST. */
1908 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1909 stmtblock_t * pre, stmtblock_t * post)
1911 gfc_interface_sym_mapping *sym;
1915 for (sym = mapping->syms; sym; sym = sym->next)
1916 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1917 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1919 expr = sym->new_sym->n.sym->ts.u.cl->length;
1920 gfc_apply_interface_mapping_to_expr (mapping, expr);
1921 gfc_init_se (&se, NULL);
1922 gfc_conv_expr (&se, expr);
1923 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1924 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1925 gfc_add_block_to_block (pre, &se.pre);
1926 gfc_add_block_to_block (post, &se.post);
1928 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1933 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1937 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1938 gfc_constructor_base base)
1941 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1943 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1946 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1947 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1948 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1954 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1958 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1963 for (; ref; ref = ref->next)
1967 for (n = 0; n < ref->u.ar.dimen; n++)
1969 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1970 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1971 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1973 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1980 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1981 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1987 /* Convert intrinsic function calls into result expressions. */
1990 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1998 arg1 = expr->value.function.actual->expr;
1999 if (expr->value.function.actual->next)
2000 arg2 = expr->value.function.actual->next->expr;
2004 sym = arg1->symtree->n.sym;
2006 if (sym->attr.dummy)
2011 switch (expr->value.function.isym->id)
2014 /* TODO figure out why this condition is necessary. */
2015 if (sym->attr.function
2016 && (arg1->ts.u.cl->length == NULL
2017 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2018 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2021 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2025 if (!sym->as || sym->as->rank == 0)
2028 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2030 dup = mpz_get_si (arg2->value.integer);
2035 dup = sym->as->rank;
2039 for (; d < dup; d++)
2043 if (!sym->as->upper[d] || !sym->as->lower[d])
2045 gfc_free_expr (new_expr);
2049 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2050 gfc_get_int_expr (gfc_default_integer_kind,
2052 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2054 new_expr = gfc_multiply (new_expr, tmp);
2060 case GFC_ISYM_LBOUND:
2061 case GFC_ISYM_UBOUND:
2062 /* TODO These implementations of lbound and ubound do not limit if
2063 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2065 if (!sym->as || sym->as->rank == 0)
2068 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2069 d = mpz_get_si (arg2->value.integer) - 1;
2071 /* TODO: If the need arises, this could produce an array of
2075 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2077 if (sym->as->lower[d])
2078 new_expr = gfc_copy_expr (sym->as->lower[d]);
2082 if (sym->as->upper[d])
2083 new_expr = gfc_copy_expr (sym->as->upper[d]);
2091 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2095 gfc_replace_expr (expr, new_expr);
2101 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2102 gfc_interface_mapping * mapping)
2104 gfc_formal_arglist *f;
2105 gfc_actual_arglist *actual;
2107 actual = expr->value.function.actual;
2108 f = map_expr->symtree->n.sym->formal;
2110 for (; f && actual; f = f->next, actual = actual->next)
2115 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2118 if (map_expr->symtree->n.sym->attr.dimension)
2123 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2125 for (d = 0; d < as->rank; d++)
2127 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2128 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2131 expr->value.function.esym->as = as;
2134 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2136 expr->value.function.esym->ts.u.cl->length
2137 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2139 gfc_apply_interface_mapping_to_expr (mapping,
2140 expr->value.function.esym->ts.u.cl->length);
2145 /* EXPR is a copy of an expression that appeared in the interface
2146 associated with MAPPING. Walk it recursively looking for references to
2147 dummy arguments that MAPPING maps to actual arguments. Replace each such
2148 reference with a reference to the associated actual argument. */
2151 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2154 gfc_interface_sym_mapping *sym;
2155 gfc_actual_arglist *actual;
2160 /* Copying an expression does not copy its length, so do that here. */
2161 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2163 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2164 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2167 /* Apply the mapping to any references. */
2168 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2170 /* ...and to the expression's symbol, if it has one. */
2171 /* TODO Find out why the condition on expr->symtree had to be moved into
2172 the loop rather than being outside it, as originally. */
2173 for (sym = mapping->syms; sym; sym = sym->next)
2174 if (expr->symtree && sym->old == expr->symtree->n.sym)
2176 if (sym->new_sym->n.sym->backend_decl)
2177 expr->symtree = sym->new_sym;
2179 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2182 /* ...and to subexpressions in expr->value. */
2183 switch (expr->expr_type)
2188 case EXPR_SUBSTRING:
2192 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2193 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2197 for (actual = expr->value.function.actual; actual; actual = actual->next)
2198 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2200 if (expr->value.function.esym == NULL
2201 && expr->value.function.isym != NULL
2202 && expr->value.function.actual->expr->symtree
2203 && gfc_map_intrinsic_function (expr, mapping))
2206 for (sym = mapping->syms; sym; sym = sym->next)
2207 if (sym->old == expr->value.function.esym)
2209 expr->value.function.esym = sym->new_sym->n.sym;
2210 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2211 expr->value.function.esym->result = sym->new_sym->n.sym;
2216 case EXPR_STRUCTURE:
2217 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2230 /* Evaluate interface expression EXPR using MAPPING. Store the result
2234 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2235 gfc_se * se, gfc_expr * expr)
2237 expr = gfc_copy_expr (expr);
2238 gfc_apply_interface_mapping_to_expr (mapping, expr);
2239 gfc_conv_expr (se, expr);
2240 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2241 gfc_free_expr (expr);
2245 /* Returns a reference to a temporary array into which a component of
2246 an actual argument derived type array is copied and then returned
2247 after the function call. */
2249 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2250 sym_intent intent, bool formal_ptr)
2268 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2270 gfc_init_se (&lse, NULL);
2271 gfc_init_se (&rse, NULL);
2273 /* Walk the argument expression. */
2274 rss = gfc_walk_expr (expr);
2276 gcc_assert (rss != gfc_ss_terminator);
2278 /* Initialize the scalarizer. */
2279 gfc_init_loopinfo (&loop);
2280 gfc_add_ss_to_loop (&loop, rss);
2282 /* Calculate the bounds of the scalarization. */
2283 gfc_conv_ss_startstride (&loop);
2285 /* Build an ss for the temporary. */
2286 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2287 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2289 base_type = gfc_typenode_for_spec (&expr->ts);
2290 if (GFC_ARRAY_TYPE_P (base_type)
2291 || GFC_DESCRIPTOR_TYPE_P (base_type))
2292 base_type = gfc_get_element_type (base_type);
2294 loop.temp_ss = gfc_get_ss ();;
2295 loop.temp_ss->type = GFC_SS_TEMP;
2296 loop.temp_ss->data.temp.type = base_type;
2298 if (expr->ts.type == BT_CHARACTER)
2299 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2301 loop.temp_ss->string_length = NULL;
2303 parmse->string_length = loop.temp_ss->string_length;
2304 loop.temp_ss->data.temp.dimen = loop.dimen;
2305 loop.temp_ss->next = gfc_ss_terminator;
2307 /* Associate the SS with the loop. */
2308 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2310 /* Setup the scalarizing loops. */
2311 gfc_conv_loop_setup (&loop, &expr->where);
2313 /* Pass the temporary descriptor back to the caller. */
2314 info = &loop.temp_ss->data.info;
2315 parmse->expr = info->descriptor;
2317 /* Setup the gfc_se structures. */
2318 gfc_copy_loopinfo_to_se (&lse, &loop);
2319 gfc_copy_loopinfo_to_se (&rse, &loop);
2322 lse.ss = loop.temp_ss;
2323 gfc_mark_ss_chain_used (rss, 1);
2324 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2326 /* Start the scalarized loop body. */
2327 gfc_start_scalarized_body (&loop, &body);
2329 /* Translate the expression. */
2330 gfc_conv_expr (&rse, expr);
2332 gfc_conv_tmp_array_ref (&lse);
2333 gfc_advance_se_ss_chain (&lse);
2335 if (intent != INTENT_OUT)
2337 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2338 gfc_add_expr_to_block (&body, tmp);
2339 gcc_assert (rse.ss == gfc_ss_terminator);
2340 gfc_trans_scalarizing_loops (&loop, &body);
2344 /* Make sure that the temporary declaration survives by merging
2345 all the loop declarations into the current context. */
2346 for (n = 0; n < loop.dimen; n++)
2348 gfc_merge_block_scope (&body);
2349 body = loop.code[loop.order[n]];
2351 gfc_merge_block_scope (&body);
2354 /* Add the post block after the second loop, so that any
2355 freeing of allocated memory is done at the right time. */
2356 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2358 /**********Copy the temporary back again.*********/
2360 gfc_init_se (&lse, NULL);
2361 gfc_init_se (&rse, NULL);
2363 /* Walk the argument expression. */
2364 lss = gfc_walk_expr (expr);
2365 rse.ss = loop.temp_ss;
2368 /* Initialize the scalarizer. */
2369 gfc_init_loopinfo (&loop2);
2370 gfc_add_ss_to_loop (&loop2, lss);
2372 /* Calculate the bounds of the scalarization. */
2373 gfc_conv_ss_startstride (&loop2);
2375 /* Setup the scalarizing loops. */
2376 gfc_conv_loop_setup (&loop2, &expr->where);
2378 gfc_copy_loopinfo_to_se (&lse, &loop2);
2379 gfc_copy_loopinfo_to_se (&rse, &loop2);
2381 gfc_mark_ss_chain_used (lss, 1);
2382 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2384 /* Declare the variable to hold the temporary offset and start the
2385 scalarized loop body. */
2386 offset = gfc_create_var (gfc_array_index_type, NULL);
2387 gfc_start_scalarized_body (&loop2, &body);
2389 /* Build the offsets for the temporary from the loop variables. The
2390 temporary array has lbounds of zero and strides of one in all
2391 dimensions, so this is very simple. The offset is only computed
2392 outside the innermost loop, so the overall transfer could be
2393 optimized further. */
2394 info = &rse.ss->data.info;
2395 dimen = info->dimen;
2397 tmp_index = gfc_index_zero_node;
2398 for (n = dimen - 1; n > 0; n--)
2401 tmp = rse.loop->loopvar[n];
2402 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2403 tmp, rse.loop->from[n]);
2404 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2407 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2408 rse.loop->to[n-1], rse.loop->from[n-1]);
2409 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2410 tmp_str, gfc_index_one_node);
2412 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2416 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2417 tmp_index, rse.loop->from[0]);
2418 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2420 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2421 rse.loop->loopvar[0], offset);
2423 /* Now use the offset for the reference. */
2424 tmp = build_fold_indirect_ref_loc (input_location,
2426 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2428 if (expr->ts.type == BT_CHARACTER)
2429 rse.string_length = expr->ts.u.cl->backend_decl;
2431 gfc_conv_expr (&lse, expr);
2433 gcc_assert (lse.ss == gfc_ss_terminator);
2435 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2436 gfc_add_expr_to_block (&body, tmp);
2438 /* Generate the copying loops. */
2439 gfc_trans_scalarizing_loops (&loop2, &body);
2441 /* Wrap the whole thing up by adding the second loop to the post-block
2442 and following it by the post-block of the first loop. In this way,
2443 if the temporary needs freeing, it is done after use! */
2444 if (intent != INTENT_IN)
2446 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2447 gfc_add_block_to_block (&parmse->post, &loop2.post);
2450 gfc_add_block_to_block (&parmse->post, &loop.post);
2452 gfc_cleanup_loop (&loop);
2453 gfc_cleanup_loop (&loop2);
2455 /* Pass the string length to the argument expression. */
2456 if (expr->ts.type == BT_CHARACTER)
2457 parmse->string_length = expr->ts.u.cl->backend_decl;
2459 /* Determine the offset for pointer formal arguments and set the
2463 size = gfc_index_one_node;
2464 offset = gfc_index_zero_node;
2465 for (n = 0; n < dimen; n++)
2467 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2469 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2470 tmp, gfc_index_one_node);
2471 gfc_conv_descriptor_ubound_set (&parmse->pre,
2475 gfc_conv_descriptor_lbound_set (&parmse->pre,
2478 gfc_index_one_node);
2479 size = gfc_evaluate_now (size, &parmse->pre);
2480 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2482 offset = gfc_evaluate_now (offset, &parmse->pre);
2483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2484 rse.loop->to[n], rse.loop->from[n]);
2485 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2486 tmp, gfc_index_one_node);
2487 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2491 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2495 /* We want either the address for the data or the address of the descriptor,
2496 depending on the mode of passing array arguments. */
2498 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2500 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2506 /* Generate the code for argument list functions. */
2509 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2511 /* Pass by value for g77 %VAL(arg), pass the address
2512 indirectly for %LOC, else by reference. Thus %REF
2513 is a "do-nothing" and %LOC is the same as an F95
2515 if (strncmp (name, "%VAL", 4) == 0)
2516 gfc_conv_expr (se, expr);
2517 else if (strncmp (name, "%LOC", 4) == 0)
2519 gfc_conv_expr_reference (se, expr);
2520 se->expr = gfc_build_addr_expr (NULL, se->expr);
2522 else if (strncmp (name, "%REF", 4) == 0)
2523 gfc_conv_expr_reference (se, expr);
2525 gfc_error ("Unknown argument list function at %L", &expr->where);
2529 /* Takes a derived type expression and returns the address of a temporary
2530 class object of the 'declared' type. */
2532 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2533 gfc_typespec class_ts)
2537 gfc_symbol *declared = class_ts.u.derived;
2543 /* The derived type needs to be converted to a temporary
2545 tmp = gfc_typenode_for_spec (&class_ts);
2546 var = gfc_create_var (tmp, "class");
2549 cmp = gfc_find_component (declared, "$vptr", true, true);
2550 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2551 var, cmp->backend_decl, NULL_TREE);
2553 /* Remember the vtab corresponds to the derived type
2554 not to the class declared type. */
2555 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2557 gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
2558 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2559 gfc_add_modify (&parmse->pre, ctree,
2560 fold_convert (TREE_TYPE (ctree), tmp));
2562 /* Now set the data field. */
2563 cmp = gfc_find_component (declared, "$data", true, true);
2564 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2565 var, cmp->backend_decl, NULL_TREE);
2566 ss = gfc_walk_expr (e);
2567 if (ss == gfc_ss_terminator)
2570 gfc_conv_expr_reference (parmse, e);
2571 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2572 gfc_add_modify (&parmse->pre, ctree, tmp);
2577 gfc_conv_expr (parmse, e);
2578 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2581 /* Pass the address of the class object. */
2582 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2586 /* The following routine generates code for the intrinsic
2587 procedures from the ISO_C_BINDING module:
2589 * C_FUNLOC (function)
2590 * C_F_POINTER (subroutine)
2591 * C_F_PROCPOINTER (subroutine)
2592 * C_ASSOCIATED (function)
2593 One exception which is not handled here is C_F_POINTER with non-scalar
2594 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2597 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2598 gfc_actual_arglist * arg)
2603 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2605 if (arg->expr->rank == 0)
2606 gfc_conv_expr_reference (se, arg->expr);
2610 /* This is really the actual arg because no formal arglist is
2611 created for C_LOC. */
2612 fsym = arg->expr->symtree->n.sym;
2614 /* We should want it to do g77 calling convention. */
2616 && !(fsym->attr.pointer || fsym->attr.allocatable)
2617 && fsym->as->type != AS_ASSUMED_SHAPE;
2618 f = f || !sym->attr.always_explicit;
2620 argss = gfc_walk_expr (arg->expr);
2621 gfc_conv_array_parameter (se, arg->expr, argss, f,
2625 /* TODO -- the following two lines shouldn't be necessary, but if
2626 they're removed, a bug is exposed later in the code path.
2627 This workaround was thus introduced, but will have to be
2628 removed; please see PR 35150 for details about the issue. */
2629 se->expr = convert (pvoid_type_node, se->expr);
2630 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2634 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2636 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2637 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2638 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2639 gfc_conv_expr_reference (se, arg->expr);
2643 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2644 && arg->next->expr->rank == 0)
2645 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2647 /* Convert c_f_pointer if fptr is a scalar
2648 and convert c_f_procpointer. */
2652 gfc_init_se (&cptrse, NULL);
2653 gfc_conv_expr (&cptrse, arg->expr);
2654 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2655 gfc_add_block_to_block (&se->post, &cptrse.post);
2657 gfc_init_se (&fptrse, NULL);
2658 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2659 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2660 fptrse.want_pointer = 1;
2662 gfc_conv_expr (&fptrse, arg->next->expr);
2663 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2664 gfc_add_block_to_block (&se->post, &fptrse.post);
2666 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2667 && arg->next->expr->symtree->n.sym->attr.dummy)
2668 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2671 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2673 fold_convert (TREE_TYPE (fptrse.expr),
2678 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2683 /* Build the addr_expr for the first argument. The argument is
2684 already an *address* so we don't need to set want_pointer in
2686 gfc_init_se (&arg1se, NULL);
2687 gfc_conv_expr (&arg1se, arg->expr);
2688 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2689 gfc_add_block_to_block (&se->post, &arg1se.post);
2691 /* See if we were given two arguments. */
2692 if (arg->next == NULL)
2693 /* Only given one arg so generate a null and do a
2694 not-equal comparison against the first arg. */
2695 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2696 fold_convert (TREE_TYPE (arg1se.expr),
2697 null_pointer_node));
2703 /* Given two arguments so build the arg2se from second arg. */
2704 gfc_init_se (&arg2se, NULL);
2705 gfc_conv_expr (&arg2se, arg->next->expr);
2706 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2707 gfc_add_block_to_block (&se->post, &arg2se.post);
2709 /* Generate test to compare that the two args are equal. */
2710 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2711 arg1se.expr, arg2se.expr);
2712 /* Generate test to ensure that the first arg is not null. */
2713 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2714 arg1se.expr, null_pointer_node);
2716 /* Finally, the generated test must check that both arg1 is not
2717 NULL and that it is equal to the second arg. */
2718 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2719 not_null_expr, eq_expr);
2725 /* Nothing was done. */
2729 /* Generate code for a procedure call. Note can return se->post != NULL.
2730 If se->direct_byref is set then se->expr contains the return parameter.
2731 Return nonzero, if the call has alternate specifiers.
2732 'expr' is only needed for procedure pointer components. */
2735 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2736 gfc_actual_arglist * arg, gfc_expr * expr,
2737 VEC(tree,gc) *append_args)
2739 gfc_interface_mapping mapping;
2740 VEC(tree,gc) *arglist;
2741 VEC(tree,gc) *retargs;
2752 VEC(tree,gc) *stringargs;
2754 gfc_formal_arglist *formal;
2755 int has_alternate_specifier = 0;
2756 bool need_interface_mapping;
2763 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2764 gfc_component *comp = NULL;
2774 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2775 && conv_isocbinding_procedure (se, sym, arg))
2778 gfc_is_proc_ptr_comp (expr, &comp);
2782 if (!sym->attr.elemental)
2784 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2785 if (se->ss->useflags)
2787 gcc_assert ((!comp && gfc_return_by_reference (sym)
2788 && sym->result->attr.dimension)
2789 || (comp && comp->attr.dimension));
2790 gcc_assert (se->loop != NULL);
2792 /* Access the previously obtained result. */
2793 gfc_conv_tmp_array_ref (se);
2794 gfc_advance_se_ss_chain (se);
2798 info = &se->ss->data.info;
2803 gfc_init_block (&post);
2804 gfc_init_interface_mapping (&mapping);
2807 formal = sym->formal;
2808 need_interface_mapping = sym->attr.dimension ||
2809 (sym->ts.type == BT_CHARACTER
2810 && sym->ts.u.cl->length
2811 && sym->ts.u.cl->length->expr_type
2816 formal = comp->formal;
2817 need_interface_mapping = comp->attr.dimension ||
2818 (comp->ts.type == BT_CHARACTER
2819 && comp->ts.u.cl->length
2820 && comp->ts.u.cl->length->expr_type
2824 /* Evaluate the arguments. */
2825 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2828 fsym = formal ? formal->sym : NULL;
2829 parm_kind = MISSING;
2833 if (se->ignore_optional)
2835 /* Some intrinsics have already been resolved to the correct
2839 else if (arg->label)
2841 has_alternate_specifier = 1;
2846 /* Pass a NULL pointer for an absent arg. */
2847 gfc_init_se (&parmse, NULL);
2848 parmse.expr = null_pointer_node;
2849 if (arg->missing_arg_type == BT_CHARACTER)
2850 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2853 else if (fsym && fsym->ts.type == BT_CLASS
2854 && e->ts.type == BT_DERIVED)
2856 /* The derived type needs to be converted to a temporary
2858 gfc_init_se (&parmse, se);
2859 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2861 else if (se->ss && se->ss->useflags)
2863 /* An elemental function inside a scalarized loop. */
2864 gfc_init_se (&parmse, se);
2865 gfc_conv_expr_reference (&parmse, e);
2866 parm_kind = ELEMENTAL;
2870 /* A scalar or transformational function. */
2871 gfc_init_se (&parmse, NULL);
2872 argss = gfc_walk_expr (e);
2874 if (argss == gfc_ss_terminator)
2876 if (e->expr_type == EXPR_VARIABLE
2877 && e->symtree->n.sym->attr.cray_pointee
2878 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2880 /* The Cray pointer needs to be converted to a pointer to
2881 a type given by the expression. */
2882 gfc_conv_expr (&parmse, e);
2883 type = build_pointer_type (TREE_TYPE (parmse.expr));
2884 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2885 parmse.expr = convert (type, tmp);
2887 else if (fsym && fsym->attr.value)
2889 if (fsym->ts.type == BT_CHARACTER
2890 && fsym->ts.is_c_interop
2891 && fsym->ns->proc_name != NULL
2892 && fsym->ns->proc_name->attr.is_bind_c)
2895 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2896 if (parmse.expr == NULL)
2897 gfc_conv_expr (&parmse, e);
2900 gfc_conv_expr (&parmse, e);
2902 else if (arg->name && arg->name[0] == '%')
2903 /* Argument list functions %VAL, %LOC and %REF are signalled
2904 through arg->name. */
2905 conv_arglist_function (&parmse, arg->expr, arg->name);
2906 else if ((e->expr_type == EXPR_FUNCTION)
2907 && ((e->value.function.esym
2908 && e->value.function.esym->result->attr.pointer)
2909 || (!e->value.function.esym
2910 && e->symtree->n.sym->attr.pointer))
2911 && fsym && fsym->attr.target)
2913 gfc_conv_expr (&parmse, e);
2914 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2916 else if (e->expr_type == EXPR_FUNCTION
2917 && e->symtree->n.sym->result
2918 && e->symtree->n.sym->result != e->symtree->n.sym
2919 && e->symtree->n.sym->result->attr.proc_pointer)
2921 /* Functions returning procedure pointers. */
2922 gfc_conv_expr (&parmse, e);
2923 if (fsym && fsym->attr.proc_pointer)
2924 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2928 gfc_conv_expr_reference (&parmse, e);
2930 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2931 allocated on entry, it must be deallocated. */
2932 if (fsym && fsym->attr.allocatable
2933 && fsym->attr.intent == INTENT_OUT)
2937 gfc_init_block (&block);
2938 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2940 gfc_add_expr_to_block (&block, tmp);
2941 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2942 parmse.expr, null_pointer_node);
2943 gfc_add_expr_to_block (&block, tmp);
2945 if (fsym->attr.optional
2946 && e->expr_type == EXPR_VARIABLE
2947 && e->symtree->n.sym->attr.optional)
2949 tmp = fold_build3 (COND_EXPR, void_type_node,
2950 gfc_conv_expr_present (e->symtree->n.sym),
2951 gfc_finish_block (&block),
2952 build_empty_stmt (input_location));
2955 tmp = gfc_finish_block (&block);
2957 gfc_add_expr_to_block (&se->pre, tmp);
2960 if (fsym && e->expr_type != EXPR_NULL
2961 && ((fsym->attr.pointer
2962 && fsym->attr.flavor != FL_PROCEDURE)
2963 || (fsym->attr.proc_pointer
2964 && !(e->expr_type == EXPR_VARIABLE
2965 && e->symtree->n.sym->attr.dummy))
2966 || (e->expr_type == EXPR_VARIABLE
2967 && gfc_is_proc_ptr_comp (e, NULL))
2968 || fsym->attr.allocatable))
2970 /* Scalar pointer dummy args require an extra level of
2971 indirection. The null pointer already contains
2972 this level of indirection. */
2973 parm_kind = SCALAR_POINTER;
2974 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2980 /* If the procedure requires an explicit interface, the actual
2981 argument is passed according to the corresponding formal
2982 argument. If the corresponding formal argument is a POINTER,
2983 ALLOCATABLE or assumed shape, we do not use g77's calling
2984 convention, and pass the address of the array descriptor
2985 instead. Otherwise we use g77's calling convention. */
2988 && !(fsym->attr.pointer || fsym->attr.allocatable)
2989 && fsym->as->type != AS_ASSUMED_SHAPE;
2991 f = f || !comp->attr.always_explicit;
2993 f = f || !sym->attr.always_explicit;
2995 if (e->expr_type == EXPR_VARIABLE
2996 && is_subref_array (e))
2997 /* The actual argument is a component reference to an
2998 array of derived types. In this case, the argument
2999 is converted to a temporary, which is passed and then
3000 written back after the procedure call. */
3001 gfc_conv_subref_array_arg (&parmse, e, f,
3002 fsym ? fsym->attr.intent : INTENT_INOUT,
3003 fsym && fsym->attr.pointer);
3005 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3008 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3009 allocated on entry, it must be deallocated. */
3010 if (fsym && fsym->attr.allocatable
3011 && fsym->attr.intent == INTENT_OUT)
3013 tmp = build_fold_indirect_ref_loc (input_location,
3015 tmp = gfc_trans_dealloc_allocated (tmp);
3016 if (fsym->attr.optional
3017 && e->expr_type == EXPR_VARIABLE
3018 && e->symtree->n.sym->attr.optional)
3019 tmp = fold_build3 (COND_EXPR, void_type_node,
3020 gfc_conv_expr_present (e->symtree->n.sym),
3021 tmp, build_empty_stmt (input_location));
3022 gfc_add_expr_to_block (&se->pre, tmp);
3027 /* The case with fsym->attr.optional is that of a user subroutine
3028 with an interface indicating an optional argument. When we call
3029 an intrinsic subroutine, however, fsym is NULL, but we might still
3030 have an optional argument, so we proceed to the substitution
3032 if (e && (fsym == NULL || fsym->attr.optional))
3034 /* If an optional argument is itself an optional dummy argument,
3035 check its presence and substitute a null if absent. This is
3036 only needed when passing an array to an elemental procedure
3037 as then array elements are accessed - or no NULL pointer is
3038 allowed and a "1" or "0" should be passed if not present.
3039 When passing a non-array-descriptor full array to a
3040 non-array-descriptor dummy, no check is needed. For
3041 array-descriptor actual to array-descriptor dummy, see
3042 PR 41911 for why a check has to be inserted.
3043 fsym == NULL is checked as intrinsics required the descriptor
3044 but do not always set fsym. */
3045 if (e->expr_type == EXPR_VARIABLE
3046 && e->symtree->n.sym->attr.optional
3047 && ((e->rank > 0 && sym->attr.elemental)
3048 || e->representation.length || e->ts.type == BT_CHARACTER
3050 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3051 || fsym->as->type == AS_DEFERRED))))
3052 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3053 e->representation.length);
3058 /* Obtain the character length of an assumed character length
3059 length procedure from the typespec. */
3060 if (fsym->ts.type == BT_CHARACTER
3061 && parmse.string_length == NULL_TREE
3062 && e->ts.type == BT_PROCEDURE
3063 && e->symtree->n.sym->ts.type == BT_CHARACTER
3064 && e->symtree->n.sym->ts.u.cl->length != NULL
3065 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3067 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3068 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3072 if (fsym && need_interface_mapping && e)
3073 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3075 gfc_add_block_to_block (&se->pre, &parmse.pre);
3076 gfc_add_block_to_block (&post, &parmse.post);
3078 /* Allocated allocatable components of derived types must be
3079 deallocated for non-variable scalars. Non-variable arrays are
3080 dealt with in trans-array.c(gfc_conv_array_parameter). */
3081 if (e && e->ts.type == BT_DERIVED
3082 && e->ts.u.derived->attr.alloc_comp
3083 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3084 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3087 tmp = build_fold_indirect_ref_loc (input_location,
3089 parm_rank = e->rank;
3097 case (SCALAR_POINTER):
3098 tmp = build_fold_indirect_ref_loc (input_location,
3103 if (e->expr_type == EXPR_OP
3104 && e->value.op.op == INTRINSIC_PARENTHESES
3105 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3108 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3109 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3110 gfc_add_expr_to_block (&se->post, local_tmp);
3113 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3115 gfc_add_expr_to_block (&se->post, tmp);
3118 /* Add argument checking of passing an unallocated/NULL actual to
3119 a nonallocatable/nonpointer dummy. */
3121 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3123 symbol_attribute *attr;
3127 if (e->expr_type == EXPR_VARIABLE)
3128 attr = &e->symtree->n.sym->attr;
3129 else if (e->expr_type == EXPR_FUNCTION)
3131 /* For intrinsic functions, the gfc_attr are not available. */
3132 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3133 goto end_pointer_check;
3135 if (e->symtree->n.sym->attr.generic)
3136 attr = &e->value.function.esym->attr;
3138 attr = &e->symtree->n.sym->result->attr;
3141 goto end_pointer_check;
3145 /* If the actual argument is an optional pointer/allocatable and
3146 the formal argument takes an nonpointer optional value,
3147 it is invalid to pass a non-present argument on, even
3148 though there is no technical reason for this in gfortran.
3149 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3150 tree present, null_ptr, type;
3152 if (attr->allocatable
3153 && (fsym == NULL || !fsym->attr.allocatable))
3154 asprintf (&msg, "Allocatable actual argument '%s' is not "
3155 "allocated or not present", e->symtree->n.sym->name);
3156 else if (attr->pointer
3157 && (fsym == NULL || !fsym->attr.pointer))
3158 asprintf (&msg, "Pointer actual argument '%s' is not "
3159 "associated or not present",
3160 e->symtree->n.sym->name);
3161 else if (attr->proc_pointer
3162 && (fsym == NULL || !fsym->attr.proc_pointer))
3163 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3164 "associated or not present",
3165 e->symtree->n.sym->name);
3167 goto end_pointer_check;
3169 present = gfc_conv_expr_present (e->symtree->n.sym);
3170 type = TREE_TYPE (present);
3171 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3172 fold_convert (type, null_pointer_node));
3173 type = TREE_TYPE (parmse.expr);
3174 null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3175 fold_convert (type, null_pointer_node));
3176 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3181 if (attr->allocatable
3182 && (fsym == NULL || !fsym->attr.allocatable))
3183 asprintf (&msg, "Allocatable actual argument '%s' is not "
3184 "allocated", e->symtree->n.sym->name);
3185 else if (attr->pointer
3186 && (fsym == NULL || !fsym->attr.pointer))
3187 asprintf (&msg, "Pointer actual argument '%s' is not "
3188 "associated", e->symtree->n.sym->name);
3189 else if (attr->proc_pointer
3190 && (fsym == NULL || !fsym->attr.proc_pointer))
3191 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3192 "associated", e->symtree->n.sym->name);
3194 goto end_pointer_check;
3197 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3198 fold_convert (TREE_TYPE (parmse.expr),
3199 null_pointer_node));
3202 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3209 /* Character strings are passed as two parameters, a length and a
3210 pointer - except for Bind(c) which only passes the pointer. */
3211 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3212 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3214 VEC_safe_push (tree, gc, arglist, parmse.expr);
3216 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3223 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3224 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3225 else if (ts.type == BT_CHARACTER)
3227 if (ts.u.cl->length == NULL)
3229 /* Assumed character length results are not allowed by 5.1.1.5 of the
3230 standard and are trapped in resolve.c; except in the case of SPREAD
3231 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3232 we take the character length of the first argument for the result.
3233 For dummies, we have to look through the formal argument list for
3234 this function and use the character length found there.*/
3235 if (!sym->attr.dummy)
3236 cl.backend_decl = VEC_index (tree, stringargs, 0);
3239 formal = sym->ns->proc_name->formal;
3240 for (; formal; formal = formal->next)
3241 if (strcmp (formal->sym->name, sym->name) == 0)
3242 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3249 /* Calculate the length of the returned string. */
3250 gfc_init_se (&parmse, NULL);
3251 if (need_interface_mapping)
3252 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3254 gfc_conv_expr (&parmse, ts.u.cl->length);
3255 gfc_add_block_to_block (&se->pre, &parmse.pre);
3256 gfc_add_block_to_block (&se->post, &parmse.post);
3258 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3259 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3260 build_int_cst (gfc_charlen_type_node, 0));
3261 cl.backend_decl = tmp;
3264 /* Set up a charlen structure for it. */
3269 len = cl.backend_decl;
3272 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3273 || (!comp && gfc_return_by_reference (sym));
3276 if (se->direct_byref)
3278 /* Sometimes, too much indirection can be applied; e.g. for
3279 function_result = array_valued_recursive_function. */
3280 if (TREE_TYPE (TREE_TYPE (se->expr))
3281 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3282 && GFC_DESCRIPTOR_TYPE_P
3283 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3284 se->expr = build_fold_indirect_ref_loc (input_location,
3287 result = build_fold_indirect_ref_loc (input_location,
3289 VEC_safe_push (tree, gc, retargs, se->expr);
3291 else if (comp && comp->attr.dimension)
3293 gcc_assert (se->loop && info);
3295 /* Set the type of the array. */
3296 tmp = gfc_typenode_for_spec (&comp->ts);
3297 info->dimen = se->loop->dimen;
3299 /* Evaluate the bounds of the result, if known. */
3300 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3302 /* Create a temporary to store the result. In case the function
3303 returns a pointer, the temporary will be a shallow copy and
3304 mustn't be deallocated. */
3305 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3306 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3307 NULL_TREE, false, !comp->attr.pointer,
3308 callee_alloc, &se->ss->expr->where);
3310 /* Pass the temporary as the first argument. */
3311 result = info->descriptor;
3312 tmp = gfc_build_addr_expr (NULL_TREE, result);
3313 VEC_safe_push (tree, gc, retargs, tmp);
3315 else if (!comp && sym->result->attr.dimension)
3317 gcc_assert (se->loop && info);
3319 /* Set the type of the array. */
3320 tmp = gfc_typenode_for_spec (&ts);
3321 info->dimen = se->loop->dimen;
3323 /* Evaluate the bounds of the result, if known. */
3324 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3326 /* Create a temporary to store the result. In case the function
3327 returns a pointer, the temporary will be a shallow copy and
3328 mustn't be deallocated. */
3329 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3330 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3331 NULL_TREE, false, !sym->attr.pointer,
3332 callee_alloc, &se->ss->expr->where);
3334 /* Pass the temporary as the first argument. */
3335 result = info->descriptor;
3336 tmp = gfc_build_addr_expr (NULL_TREE, result);
3337 VEC_safe_push (tree, gc, retargs, tmp);
3339 else if (ts.type == BT_CHARACTER)
3341 /* Pass the string length. */
3342 type = gfc_get_character_type (ts.kind, ts.u.cl);
3343 type = build_pointer_type (type);
3345 /* Return an address to a char[0:len-1]* temporary for
3346 character pointers. */
3347 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3348 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3350 var = gfc_create_var (type, "pstr");
3352 if ((!comp && sym->attr.allocatable)
3353 || (comp && comp->attr.allocatable))
3354 gfc_add_modify (&se->pre, var,
3355 fold_convert (TREE_TYPE (var),
3356 null_pointer_node));
3358 /* Provide an address expression for the function arguments. */
3359 var = gfc_build_addr_expr (NULL_TREE, var);
3362 var = gfc_conv_string_tmp (se, type, len);
3364 VEC_safe_push (tree, gc, retargs, var);
3368 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3370 type = gfc_get_complex_type (ts.kind);
3371 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3372 VEC_safe_push (tree, gc, retargs, var);
3375 /* Add the string length to the argument list. */
3376 if (ts.type == BT_CHARACTER)
3377 VEC_safe_push (tree, gc, retargs, len);
3379 gfc_free_interface_mapping (&mapping);
3381 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3382 arglen = (VEC_length (tree, arglist)
3383 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3384 VEC_reserve_exact (tree, gc, retargs, arglen);
3386 /* Add the return arguments. */
3387 VEC_splice (tree, retargs, arglist);
3389 /* Add the hidden string length parameters to the arguments. */
3390 VEC_splice (tree, retargs, stringargs);
3392 /* We may want to append extra arguments here. This is used e.g. for
3393 calls to libgfortran_matmul_??, which need extra information. */
3394 if (!VEC_empty (tree, append_args))
3395 VEC_splice (tree, retargs, append_args);
3398 /* Generate the actual call. */
3399 conv_function_val (se, sym, expr);
3401 /* If there are alternate return labels, function type should be
3402 integer. Can't modify the type in place though, since it can be shared
3403 with other functions. For dummy arguments, the typing is done to
3404 to this result, even if it has to be repeated for each call. */
3405 if (has_alternate_specifier
3406 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3408 if (!sym->attr.dummy)
3410 TREE_TYPE (sym->backend_decl)
3411 = build_function_type (integer_type_node,
3412 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3413 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3416 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3419 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3420 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3422 /* If we have a pointer function, but we don't want a pointer, e.g.
3425 where f is pointer valued, we have to dereference the result. */
3426 if (!se->want_pointer && !byref
3427 && (sym->attr.pointer || sym->attr.allocatable)
3428 && !gfc_is_proc_ptr_comp (expr, NULL))
3429 se->expr = build_fold_indirect_ref_loc (input_location,
3432 /* f2c calling conventions require a scalar default real function to
3433 return a double precision result. Convert this back to default
3434 real. We only care about the cases that can happen in Fortran 77.
3436 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3437 && sym->ts.kind == gfc_default_real_kind
3438 && !sym->attr.always_explicit)
3439 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3441 /* A pure function may still have side-effects - it may modify its
3443 TREE_SIDE_EFFECTS (se->expr) = 1;
3445 if (!sym->attr.pure)
3446 TREE_SIDE_EFFECTS (se->expr) = 1;
3451 /* Add the function call to the pre chain. There is no expression. */
3452 gfc_add_expr_to_block (&se->pre, se->expr);
3453 se->expr = NULL_TREE;
3455 if (!se->direct_byref)
3457 if (sym->attr.dimension || (comp && comp->attr.dimension))
3459 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3461 /* Check the data pointer hasn't been modified. This would
3462 happen in a function returning a pointer. */
3463 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3464 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3466 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3469 se->expr = info->descriptor;
3470 /* Bundle in the string length. */
3471 se->string_length = len;
3473 else if (ts.type == BT_CHARACTER)
3475 /* Dereference for character pointer results. */
3476 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3477 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3478 se->expr = build_fold_indirect_ref_loc (input_location, var);
3482 se->string_length = len;
3486 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3487 se->expr = build_fold_indirect_ref_loc (input_location, var);
3492 /* Follow the function call with the argument post block. */
3495 gfc_add_block_to_block (&se->pre, &post);
3497 /* Transformational functions of derived types with allocatable
3498 components must have the result allocatable components copied. */
3499 arg = expr->value.function.actual;
3500 if (result && arg && expr->rank
3501 && expr->value.function.isym
3502 && expr->value.function.isym->transformational
3503 && arg->expr->ts.type == BT_DERIVED
3504 && arg->expr->ts.u.derived->attr.alloc_comp)
3507 /* Copy the allocatable components. We have to use a
3508 temporary here to prevent source allocatable components
3509 from being corrupted. */
3510 tmp2 = gfc_evaluate_now (result, &se->pre);
3511 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3512 result, tmp2, expr->rank);
3513 gfc_add_expr_to_block (&se->pre, tmp);
3514 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3516 gfc_add_expr_to_block (&se->pre, tmp);
3518 /* Finally free the temporary's data field. */
3519 tmp = gfc_conv_descriptor_data_get (tmp2);
3520 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3521 gfc_add_expr_to_block (&se->pre, tmp);
3525 gfc_add_block_to_block (&se->post, &post);
3527 return has_alternate_specifier;
3531 /* Fill a character string with spaces. */
3534 fill_with_spaces (tree start, tree type, tree size)
3536 stmtblock_t block, loop;
3537 tree i, el, exit_label, cond, tmp;
3539 /* For a simple char type, we can call memset(). */
3540 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3541 return build_call_expr_loc (input_location,
3542 built_in_decls[BUILT_IN_MEMSET], 3, start,
3543 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3544 lang_hooks.to_target_charset (' ')),
3547 /* Otherwise, we use a loop:
3548 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3552 /* Initialize variables. */
3553 gfc_init_block (&block);
3554 i = gfc_create_var (sizetype, "i");
3555 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3556 el = gfc_create_var (build_pointer_type (type), "el");
3557 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3558 exit_label = gfc_build_label_decl (NULL_TREE);
3559 TREE_USED (exit_label) = 1;
3563 gfc_init_block (&loop);
3565 /* Exit condition. */
3566 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3567 fold_convert (sizetype, integer_zero_node));
3568 tmp = build1_v (GOTO_EXPR, exit_label);
3569 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3570 build_empty_stmt (input_location));
3571 gfc_add_expr_to_block (&loop, tmp);
3574 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3575 build_int_cst (type,
3576 lang_hooks.to_target_charset (' ')));
3578 /* Increment loop variables. */
3579 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3580 TYPE_SIZE_UNIT (type)));
3581 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3583 TYPE_SIZE_UNIT (type)));
3585 /* Making the loop... actually loop! */
3586 tmp = gfc_finish_block (&loop);
3587 tmp = build1_v (LOOP_EXPR, tmp);
3588 gfc_add_expr_to_block (&block, tmp);
3590 /* The exit label. */
3591 tmp = build1_v (LABEL_EXPR, exit_label);
3592 gfc_add_expr_to_block (&block, tmp);
3595 return gfc_finish_block (&block);
3599 /* Generate code to copy a string. */
3602 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3603 int dkind, tree slength, tree src, int skind)
3605 tree tmp, dlen, slen;
3614 stmtblock_t tempblock;
3616 gcc_assert (dkind == skind);
3618 if (slength != NULL_TREE)
3620 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3621 ssc = gfc_string_to_single_character (slen, src, skind);
3625 slen = build_int_cst (size_type_node, 1);
3629 if (dlength != NULL_TREE)
3631 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3632 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3636 dlen = build_int_cst (size_type_node, 1);
3640 /* Assign directly if the types are compatible. */
3641 if (dsc != NULL_TREE && ssc != NULL_TREE
3642 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3644 gfc_add_modify (block, dsc, ssc);
3648 /* Do nothing if the destination length is zero. */
3649 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3650 build_int_cst (size_type_node, 0));
3652 /* The following code was previously in _gfortran_copy_string:
3654 // The two strings may overlap so we use memmove.
3656 copy_string (GFC_INTEGER_4 destlen, char * dest,
3657 GFC_INTEGER_4 srclen, const char * src)
3659 if (srclen >= destlen)
3661 // This will truncate if too long.
3662 memmove (dest, src, destlen);
3666 memmove (dest, src, srclen);
3668 memset (&dest[srclen], ' ', destlen - srclen);
3672 We're now doing it here for better optimization, but the logic
3675 /* For non-default character kinds, we have to multiply the string
3676 length by the base type size. */
3677 chartype = gfc_get_char_type (dkind);
3678 slen = fold_build2 (MULT_EXPR, size_type_node,
3679 fold_convert (size_type_node, slen),
3680 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3681 dlen = fold_build2 (MULT_EXPR, size_type_node,
3682 fold_convert (size_type_node, dlen),
3683 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3686 dest = fold_convert (pvoid_type_node, dest);
3688 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3691 src = fold_convert (pvoid_type_node, src);
3693 src = gfc_build_addr_expr (pvoid_type_node, src);
3695 /* Truncate string if source is too long. */
3696 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3697 tmp2 = build_call_expr_loc (input_location,
3698 built_in_decls[BUILT_IN_MEMMOVE],
3699 3, dest, src, dlen);
3701 /* Else copy and pad with spaces. */
3702 tmp3 = build_call_expr_loc (input_location,
3703 built_in_decls[BUILT_IN_MEMMOVE],
3704 3, dest, src, slen);
3706 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3707 fold_convert (sizetype, slen));
3708 tmp4 = fill_with_spaces (tmp4, chartype,
3709 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3712 gfc_init_block (&tempblock);
3713 gfc_add_expr_to_block (&tempblock, tmp3);
3714 gfc_add_expr_to_block (&tempblock, tmp4);
3715 tmp3 = gfc_finish_block (&tempblock);
3717 /* The whole copy_string function is there. */
3718 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3719 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3720 build_empty_stmt (input_location));
3721 gfc_add_expr_to_block (block, tmp);
3725 /* Translate a statement function.
3726 The value of a statement function reference is obtained by evaluating the
3727 expression using the values of the actual arguments for the values of the
3728 corresponding dummy arguments. */
3731 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3735 gfc_formal_arglist *fargs;
3736 gfc_actual_arglist *args;
3739 gfc_saved_var *saved_vars;
3745 sym = expr->symtree->n.sym;
3746 args = expr->value.function.actual;
3747 gfc_init_se (&lse, NULL);
3748 gfc_init_se (&rse, NULL);
3751 for (fargs = sym->formal; fargs; fargs = fargs->next)
3753 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3754 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3756 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3758 /* Each dummy shall be specified, explicitly or implicitly, to be
3760 gcc_assert (fargs->sym->attr.dimension == 0);
3763 /* Create a temporary to hold the value. */
3764 type = gfc_typenode_for_spec (&fsym->ts);
3765 temp_vars[n] = gfc_create_var (type, fsym->name);
3767 if (fsym->ts.type == BT_CHARACTER)
3769 /* Copy string arguments. */
3772 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3773 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3775 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3776 tmp = gfc_build_addr_expr (build_pointer_type (type),
3779 gfc_conv_expr (&rse, args->expr);
3780 gfc_conv_string_parameter (&rse);
3781 gfc_add_block_to_block (&se->pre, &lse.pre);
3782 gfc_add_block_to_block (&se->pre, &rse.pre);
3784 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3785 rse.string_length, rse.expr, fsym->ts.kind);
3786 gfc_add_block_to_block (&se->pre, &lse.post);
3787 gfc_add_block_to_block (&se->pre, &rse.post);
3791 /* For everything else, just evaluate the expression. */
3792 gfc_conv_expr (&lse, args->expr);
3794 gfc_add_block_to_block (&se->pre, &lse.pre);
3795 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3796 gfc_add_block_to_block (&se->pre, &lse.post);
3802 /* Use the temporary variables in place of the real ones. */
3803 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3804 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3806 gfc_conv_expr (se, sym->value);
3808 if (sym->ts.type == BT_CHARACTER)
3810 gfc_conv_const_charlen (sym->ts.u.cl);
3812 /* Force the expression to the correct length. */
3813 if (!INTEGER_CST_P (se->string_length)
3814 || tree_int_cst_lt (se->string_length,
3815 sym->ts.u.cl->backend_decl))
3817 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3818 tmp = gfc_create_var (type, sym->name);
3819 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3820 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3821 sym->ts.kind, se->string_length, se->expr,
3825 se->string_length = sym->ts.u.cl->backend_decl;
3828 /* Restore the original variables. */
3829 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3830 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3831 gfc_free (saved_vars);
3835 /* Translate a function expression. */
3838 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3842 if (expr->value.function.isym)
3844 gfc_conv_intrinsic_function (se, expr);
3848 /* We distinguish statement functions from general functions to improve
3849 runtime performance. */
3850 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3852 gfc_conv_statement_function (se, expr);
3856 /* expr.value.function.esym is the resolved (specific) function symbol for
3857 most functions. However this isn't set for dummy procedures. */
3858 sym = expr->value.function.esym;
3860 sym = expr->symtree->n.sym;
3862 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3866 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3869 is_zero_initializer_p (gfc_expr * expr)
3871 if (expr->expr_type != EXPR_CONSTANT)
3874 /* We ignore constants with prescribed memory representations for now. */
3875 if (expr->representation.string)
3878 switch (expr->ts.type)
3881 return mpz_cmp_si (expr->value.integer, 0) == 0;
3884 return mpfr_zero_p (expr->value.real)
3885 && MPFR_SIGN (expr->value.real) >= 0;
3888 return expr->value.logical == 0;
3891 return mpfr_zero_p (mpc_realref (expr->value.complex))
3892 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3893 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3894 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3904 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3906 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3907 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3909 gfc_conv_tmp_array_ref (se);
3910 gfc_advance_se_ss_chain (se);
3914 /* Build a static initializer. EXPR is the expression for the initial value.
3915 The other parameters describe the variable of the component being
3916 initialized. EXPR may be null. */
3919 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3920 bool array, bool pointer)
3924 if (!(expr || pointer))
3927 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3928 (these are the only two iso_c_binding derived types that can be
3929 used as initialization expressions). If so, we need to modify
3930 the 'expr' to be that for a (void *). */
3931 if (expr != NULL && expr->ts.type == BT_DERIVED
3932 && expr->ts.is_iso_c && expr->ts.u.derived)
3934 gfc_symbol *derived = expr->ts.u.derived;
3936 /* The derived symbol has already been converted to a (void *). Use
3938 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3939 expr->ts.f90_type = derived->ts.f90_type;
3941 gfc_init_se (&se, NULL);
3942 gfc_conv_constant (&se, expr);
3948 /* Arrays need special handling. */
3950 return gfc_build_null_descriptor (type);
3951 /* Special case assigning an array to zero. */
3952 else if (is_zero_initializer_p (expr))
3953 return build_constructor (type, NULL);
3955 return gfc_conv_array_initializer (type, expr);
3958 return fold_convert (type, null_pointer_node);
3965 gfc_init_se (&se, NULL);
3966 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
3967 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
3969 gfc_conv_structure (&se, expr, 1);
3973 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3976 gfc_init_se (&se, NULL);
3977 gfc_conv_constant (&se, expr);
3984 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3996 gfc_start_block (&block);
3998 /* Initialize the scalarizer. */
3999 gfc_init_loopinfo (&loop);
4001 gfc_init_se (&lse, NULL);
4002 gfc_init_se (&rse, NULL);
4005 rss = gfc_walk_expr (expr);
4006 if (rss == gfc_ss_terminator)
4008 /* The rhs is scalar. Add a ss for the expression. */
4009 rss = gfc_get_ss ();
4010 rss->next = gfc_ss_terminator;
4011 rss->type = GFC_SS_SCALAR;
4015 /* Create a SS for the destination. */
4016 lss = gfc_get_ss ();
4017 lss->type = GFC_SS_COMPONENT;
4019 lss->shape = gfc_get_shape (cm->as->rank);
4020 lss->next = gfc_ss_terminator;
4021 lss->data.info.dimen = cm->as->rank;
4022 lss->data.info.descriptor = dest;
4023 lss->data.info.data = gfc_conv_array_data (dest);
4024 lss->data.info.offset = gfc_conv_array_offset (dest);
4025 for (n = 0; n < cm->as->rank; n++)
4027 lss->data.info.dim[n] = n;
4028 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4029 lss->data.info.stride[n] = gfc_index_one_node;
4031 mpz_init (lss->shape[n]);
4032 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4033 cm->as->lower[n]->value.integer);
4034 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4037 /* Associate the SS with the loop. */
4038 gfc_add_ss_to_loop (&loop, lss);
4039 gfc_add_ss_to_loop (&loop, rss);
4041 /* Calculate the bounds of the scalarization. */
4042 gfc_conv_ss_startstride (&loop);
4044 /* Setup the scalarizing loops. */
4045 gfc_conv_loop_setup (&loop, &expr->where);
4047 /* Setup the gfc_se structures. */
4048 gfc_copy_loopinfo_to_se (&lse, &loop);
4049 gfc_copy_loopinfo_to_se (&rse, &loop);
4052 gfc_mark_ss_chain_used (rss, 1);
4054 gfc_mark_ss_chain_used (lss, 1);
4056 /* Start the scalarized loop body. */
4057 gfc_start_scalarized_body (&loop, &body);
4059 gfc_conv_tmp_array_ref (&lse);
4060 if (cm->ts.type == BT_CHARACTER)
4061 lse.string_length = cm->ts.u.cl->backend_decl;
4063 gfc_conv_expr (&rse, expr);
4065 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4066 gfc_add_expr_to_block (&body, tmp);
4068 gcc_assert (rse.ss == gfc_ss_terminator);
4070 /* Generate the copying loops. */
4071 gfc_trans_scalarizing_loops (&loop, &body);
4073 /* Wrap the whole thing up. */
4074 gfc_add_block_to_block (&block, &loop.pre);
4075 gfc_add_block_to_block (&block, &loop.post);
4077 for (n = 0; n < cm->as->rank; n++)
4078 mpz_clear (lss->shape[n]);
4079 gfc_free (lss->shape);
4081 gfc_cleanup_loop (&loop);
4083 return gfc_finish_block (&block);
4088 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4099 gfc_expr *arg = NULL;
4101 gfc_start_block (&block);
4102 gfc_init_se (&se, NULL);
4104 /* Get the descriptor for the expressions. */
4105 rss = gfc_walk_expr (expr);
4106 se.want_pointer = 0;
4107 gfc_conv_expr_descriptor (&se, expr, rss);
4108 gfc_add_block_to_block (&block, &se.pre);
4109 gfc_add_modify (&block, dest, se.expr);
4111 /* Deal with arrays of derived types with allocatable components. */
4112 if (cm->ts.type == BT_DERIVED
4113 && cm->ts.u.derived->attr.alloc_comp)
4114 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4118 tmp = gfc_duplicate_allocatable (dest, se.expr,
4119 TREE_TYPE(cm->backend_decl),
4122 gfc_add_expr_to_block (&block, tmp);
4123 gfc_add_block_to_block (&block, &se.post);
4125 if (expr->expr_type != EXPR_VARIABLE)
4126 gfc_conv_descriptor_data_set (&block, se.expr,
4129 /* We need to know if the argument of a conversion function is a
4130 variable, so that the correct lower bound can be used. */
4131 if (expr->expr_type == EXPR_FUNCTION
4132 && expr->value.function.isym
4133 && expr->value.function.isym->conversion
4134 && expr->value.function.actual->expr
4135 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4136 arg = expr->value.function.actual->expr;
4138 /* Obtain the array spec of full array references. */
4140 as = gfc_get_full_arrayspec_from_expr (arg);
4142 as = gfc_get_full_arrayspec_from_expr (expr);
4144 /* Shift the lbound and ubound of temporaries to being unity,
4145 rather than zero, based. Always calculate the offset. */
4146 offset = gfc_conv_descriptor_offset_get (dest);
4147 gfc_add_modify (&block, offset, gfc_index_zero_node);
4148 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4150 for (n = 0; n < expr->rank; n++)
4155 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4156 TODO It looks as if gfc_conv_expr_descriptor should return
4157 the correct bounds and that the following should not be
4158 necessary. This would simplify gfc_conv_intrinsic_bound
4160 if (as && as->lower[n])
4163 gfc_init_se (&lbse, NULL);
4164 gfc_conv_expr (&lbse, as->lower[n]);
4165 gfc_add_block_to_block (&block, &lbse.pre);
4166 lbound = gfc_evaluate_now (lbse.expr, &block);
4170 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4171 lbound = gfc_conv_descriptor_lbound_get (tmp,
4175 lbound = gfc_conv_descriptor_lbound_get (dest,
4178 lbound = gfc_index_one_node;
4180 lbound = fold_convert (gfc_array_index_type, lbound);
4182 /* Shift the bounds and set the offset accordingly. */
4183 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4184 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4185 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4186 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4187 gfc_conv_descriptor_ubound_set (&block, dest,
4188 gfc_rank_cst[n], tmp);
4189 gfc_conv_descriptor_lbound_set (&block, dest,
4190 gfc_rank_cst[n], lbound);
4192 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4193 gfc_conv_descriptor_lbound_get (dest,
4195 gfc_conv_descriptor_stride_get (dest,
4197 gfc_add_modify (&block, tmp2, tmp);
4198 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4199 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4204 /* If a conversion expression has a null data pointer
4205 argument, nullify the allocatable component. */
4209 if (arg->symtree->n.sym->attr.allocatable
4210 || arg->symtree->n.sym->attr.pointer)
4212 non_null_expr = gfc_finish_block (&block);
4213 gfc_start_block (&block);
4214 gfc_conv_descriptor_data_set (&block, dest,
4216 null_expr = gfc_finish_block (&block);
4217 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4218 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4219 fold_convert (TREE_TYPE (tmp),
4220 null_pointer_node));
4221 return build3_v (COND_EXPR, tmp,
4222 null_expr, non_null_expr);
4226 return gfc_finish_block (&block);
4230 /* Assign a single component of a derived type constructor. */
4233 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4241 gfc_start_block (&block);
4243 if (cm->attr.pointer)
4245 gfc_init_se (&se, NULL);
4246 /* Pointer component. */
4247 if (cm->attr.dimension)
4249 /* Array pointer. */
4250 if (expr->expr_type == EXPR_NULL)
4251 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4254 rss = gfc_walk_expr (expr);
4255 se.direct_byref = 1;
4257 gfc_conv_expr_descriptor (&se, expr, rss);
4258 gfc_add_block_to_block (&block, &se.pre);
4259 gfc_add_block_to_block (&block, &se.post);
4264 /* Scalar pointers. */
4265 se.want_pointer = 1;
4266 gfc_conv_expr (&se, expr);
4267 gfc_add_block_to_block (&block, &se.pre);
4268 gfc_add_modify (&block, dest,
4269 fold_convert (TREE_TYPE (dest), se.expr));
4270 gfc_add_block_to_block (&block, &se.post);
4273 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4275 /* NULL initialization for CLASS components. */
4276 tmp = gfc_trans_structure_assign (dest,
4277 gfc_class_null_initializer (&cm->ts));
4278 gfc_add_expr_to_block (&block, tmp);
4280 else if (cm->attr.dimension)
4282 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4283 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4284 else if (cm->attr.allocatable)
4286 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4287 gfc_add_expr_to_block (&block, tmp);
4291 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4292 gfc_add_expr_to_block (&block, tmp);
4295 else if (expr->ts.type == BT_DERIVED)
4297 if (expr->expr_type != EXPR_STRUCTURE)
4299 gfc_init_se (&se, NULL);
4300 gfc_conv_expr (&se, expr);
4301 gfc_add_block_to_block (&block, &se.pre);
4302 gfc_add_modify (&block, dest,
4303 fold_convert (TREE_TYPE (dest), se.expr));
4304 gfc_add_block_to_block (&block, &se.post);
4308 /* Nested constructors. */
4309 tmp = gfc_trans_structure_assign (dest, expr);
4310 gfc_add_expr_to_block (&block, tmp);
4315 /* Scalar component. */
4316 gfc_init_se (&se, NULL);
4317 gfc_init_se (&lse, NULL);
4319 gfc_conv_expr (&se, expr);
4320 if (cm->ts.type == BT_CHARACTER)
4321 lse.string_length = cm->ts.u.cl->backend_decl;
4323 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4324 gfc_add_expr_to_block (&block, tmp);
4326 return gfc_finish_block (&block);
4329 /* Assign a derived type constructor to a variable. */
4332 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4340 gfc_start_block (&block);
4341 cm = expr->ts.u.derived->components;
4342 for (c = gfc_constructor_first (expr->value.constructor);
4343 c; c = gfc_constructor_next (c), cm = cm->next)
4345 /* Skip absent members in default initializers. */
4349 /* Handle c_null_(fun)ptr. */
4350 if (c && c->expr && c->expr->ts.is_iso_c)
4352 field = cm->backend_decl;
4353 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4354 dest, field, NULL_TREE);
4355 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4356 fold_convert (TREE_TYPE (tmp),
4357 null_pointer_node));
4358 gfc_add_expr_to_block (&block, tmp);
4362 field = cm->backend_decl;
4363 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4364 dest, field, NULL_TREE);
4365 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4366 gfc_add_expr_to_block (&block, tmp);
4368 return gfc_finish_block (&block);
4371 /* Build an expression for a constructor. If init is nonzero then
4372 this is part of a static variable initializer. */
4375 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4382 VEC(constructor_elt,gc) *v = NULL;
4384 gcc_assert (se->ss == NULL);
4385 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4386 type = gfc_typenode_for_spec (&expr->ts);
4390 /* Create a temporary variable and fill it in. */
4391 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4392 tmp = gfc_trans_structure_assign (se->expr, expr);
4393 gfc_add_expr_to_block (&se->pre, tmp);
4397 cm = expr->ts.u.derived->components;
4399 for (c = gfc_constructor_first (expr->value.constructor);
4400 c; c = gfc_constructor_next (c), cm = cm->next)
4402 /* Skip absent members in default initializers and allocatable
4403 components. Although the latter have a default initializer
4404 of EXPR_NULL,... by default, the static nullify is not needed
4405 since this is done every time we come into scope. */
4406 if (!c->expr || cm->attr.allocatable)
4409 if (strcmp (cm->name, "$size") == 0)
4411 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4412 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4414 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4415 && strcmp (cm->name, "$extends") == 0)
4419 vtabs = cm->initializer->symtree->n.sym;
4420 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4421 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4425 val = gfc_conv_initializer (c->expr, &cm->ts,
4426 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4427 cm->attr.pointer || cm->attr.proc_pointer);
4429 /* Append it to the constructor list. */
4430 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4433 se->expr = build_constructor (type, v);
4435 TREE_CONSTANT (se->expr) = 1;
4439 /* Translate a substring expression. */
4442 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4448 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4450 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4451 expr->value.character.length,
4452 expr->value.character.string);
4454 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4455 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4458 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4462 /* Entry point for expression translation. Evaluates a scalar quantity.
4463 EXPR is the expression to be translated, and SE is the state structure if
4464 called from within the scalarized. */
4467 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4469 if (se->ss && se->ss->expr == expr
4470 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4472 /* Substitute a scalar expression evaluated outside the scalarization
4474 se->expr = se->ss->data.scalar.expr;
4475 if (se->ss->type == GFC_SS_REFERENCE)
4476 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4477 se->string_length = se->ss->string_length;
4478 gfc_advance_se_ss_chain (se);
4482 /* We need to convert the expressions for the iso_c_binding derived types.
4483 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4484 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4485 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4486 updated to be an integer with a kind equal to the size of a (void *). */
4487 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4488 && expr->ts.u.derived->attr.is_iso_c)
4490 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4491 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4493 /* Set expr_type to EXPR_NULL, which will result in
4494 null_pointer_node being used below. */
4495 expr->expr_type = EXPR_NULL;
4499 /* Update the type/kind of the expression to be what the new
4500 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4501 expr->ts.type = expr->ts.u.derived->ts.type;
4502 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4503 expr->ts.kind = expr->ts.u.derived->ts.kind;
4507 switch (expr->expr_type)
4510 gfc_conv_expr_op (se, expr);
4514 gfc_conv_function_expr (se, expr);
4518 gfc_conv_constant (se, expr);
4522 gfc_conv_variable (se, expr);
4526 se->expr = null_pointer_node;
4529 case EXPR_SUBSTRING:
4530 gfc_conv_substring_expr (se, expr);
4533 case EXPR_STRUCTURE:
4534 gfc_conv_structure (se, expr, 0);
4538 gfc_conv_array_constructor_expr (se, expr);
4547 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4548 of an assignment. */
4550 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4552 gfc_conv_expr (se, expr);
4553 /* All numeric lvalues should have empty post chains. If not we need to
4554 figure out a way of rewriting an lvalue so that it has no post chain. */
4555 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4558 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4559 numeric expressions. Used for scalar values where inserting cleanup code
4562 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4566 gcc_assert (expr->ts.type != BT_CHARACTER);
4567 gfc_conv_expr (se, expr);
4570 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4571 gfc_add_modify (&se->pre, val, se->expr);
4573 gfc_add_block_to_block (&se->pre, &se->post);
4577 /* Helper to translate an expression and convert it to a particular type. */
4579 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4581 gfc_conv_expr_val (se, expr);
4582 se->expr = convert (type, se->expr);
4586 /* Converts an expression so that it can be passed by reference. Scalar
4590 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4594 if (se->ss && se->ss->expr == expr
4595 && se->ss->type == GFC_SS_REFERENCE)
4597 /* Returns a reference to the scalar evaluated outside the loop
4599 gfc_conv_expr (se, expr);
4603 if (expr->ts.type == BT_CHARACTER)
4605 gfc_conv_expr (se, expr);
4606 gfc_conv_string_parameter (se);
4610 if (expr->expr_type == EXPR_VARIABLE)
4612 se->want_pointer = 1;
4613 gfc_conv_expr (se, expr);
4616 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4617 gfc_add_modify (&se->pre, var, se->expr);
4618 gfc_add_block_to_block (&se->pre, &se->post);
4624 if (expr->expr_type == EXPR_FUNCTION
4625 && ((expr->value.function.esym
4626 && expr->value.function.esym->result->attr.pointer
4627 && !expr->value.function.esym->result->attr.dimension)
4628 || (!expr->value.function.esym
4629 && expr->symtree->n.sym->attr.pointer
4630 && !expr->symtree->n.sym->attr.dimension)))
4632 se->want_pointer = 1;
4633 gfc_conv_expr (se, expr);
4634 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4635 gfc_add_modify (&se->pre, var, se->expr);
4641 gfc_conv_expr (se, expr);
4643 /* Create a temporary var to hold the value. */
4644 if (TREE_CONSTANT (se->expr))
4646 tree tmp = se->expr;
4647 STRIP_TYPE_NOPS (tmp);
4648 var = build_decl (input_location,
4649 CONST_DECL, NULL, TREE_TYPE (tmp));
4650 DECL_INITIAL (var) = tmp;
4651 TREE_STATIC (var) = 1;
4656 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4657 gfc_add_modify (&se->pre, var, se->expr);
4659 gfc_add_block_to_block (&se->pre, &se->post);
4661 /* Take the address of that value. */
4662 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4667 gfc_trans_pointer_assign (gfc_code * code)
4669 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4673 /* Generate code for a pointer assignment. */
4676 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4687 gfc_start_block (&block);
4689 gfc_init_se (&lse, NULL);
4691 lss = gfc_walk_expr (expr1);
4692 rss = gfc_walk_expr (expr2);
4693 if (lss == gfc_ss_terminator)
4695 /* Scalar pointers. */
4696 lse.want_pointer = 1;
4697 gfc_conv_expr (&lse, expr1);
4698 gcc_assert (rss == gfc_ss_terminator);
4699 gfc_init_se (&rse, NULL);
4700 rse.want_pointer = 1;
4701 gfc_conv_expr (&rse, expr2);
4703 if (expr1->symtree->n.sym->attr.proc_pointer
4704 && expr1->symtree->n.sym->attr.dummy)
4705 lse.expr = build_fold_indirect_ref_loc (input_location,
4708 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4709 && expr2->symtree->n.sym->attr.dummy)
4710 rse.expr = build_fold_indirect_ref_loc (input_location,
4713 gfc_add_block_to_block (&block, &lse.pre);
4714 gfc_add_block_to_block (&block, &rse.pre);
4716 /* Check character lengths if character expression. The test is only
4717 really added if -fbounds-check is enabled. */
4718 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4719 && !expr1->symtree->n.sym->attr.proc_pointer
4720 && !gfc_is_proc_ptr_comp (expr1, NULL))
4722 gcc_assert (expr2->ts.type == BT_CHARACTER);
4723 gcc_assert (lse.string_length && rse.string_length);
4724 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4725 lse.string_length, rse.string_length,
4729 gfc_add_modify (&block, lse.expr,
4730 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4732 gfc_add_block_to_block (&block, &rse.post);
4733 gfc_add_block_to_block (&block, &lse.post);
4738 tree strlen_rhs = NULL_TREE;
4740 /* Array pointer. */
4741 gfc_conv_expr_descriptor (&lse, expr1, lss);
4742 strlen_lhs = lse.string_length;
4743 switch (expr2->expr_type)
4746 /* Just set the data pointer to null. */
4747 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4751 /* Assign directly to the pointer's descriptor. */
4752 lse.direct_byref = 1;
4753 gfc_conv_expr_descriptor (&lse, expr2, rss);
4754 strlen_rhs = lse.string_length;
4756 /* If this is a subreference array pointer assignment, use the rhs
4757 descriptor element size for the lhs span. */
4758 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4760 decl = expr1->symtree->n.sym->backend_decl;
4761 gfc_init_se (&rse, NULL);
4762 rse.descriptor_only = 1;
4763 gfc_conv_expr (&rse, expr2);
4764 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4765 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4766 if (!INTEGER_CST_P (tmp))
4767 gfc_add_block_to_block (&lse.post, &rse.pre);
4768 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4774 /* Assign to a temporary descriptor and then copy that
4775 temporary to the pointer. */
4777 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4780 lse.direct_byref = 1;
4781 gfc_conv_expr_descriptor (&lse, expr2, rss);
4782 strlen_rhs = lse.string_length;
4783 gfc_add_modify (&lse.pre, desc, tmp);
4787 gfc_add_block_to_block (&block, &lse.pre);
4789 /* Check string lengths if applicable. The check is only really added
4790 to the output code if -fbounds-check is enabled. */
4791 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4793 gcc_assert (expr2->ts.type == BT_CHARACTER);
4794 gcc_assert (strlen_lhs && strlen_rhs);
4795 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4796 strlen_lhs, strlen_rhs, &block);
4799 gfc_add_block_to_block (&block, &lse.post);
4801 return gfc_finish_block (&block);
4805 /* Makes sure se is suitable for passing as a function string parameter. */
4806 /* TODO: Need to check all callers of this function. It may be abused. */
4809 gfc_conv_string_parameter (gfc_se * se)
4813 if (TREE_CODE (se->expr) == STRING_CST)
4815 type = TREE_TYPE (TREE_TYPE (se->expr));
4816 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4820 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4822 if (TREE_CODE (se->expr) != INDIRECT_REF)
4824 type = TREE_TYPE (se->expr);
4825 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4829 type = gfc_get_character_type_len (gfc_default_character_kind,
4831 type = build_pointer_type (type);
4832 se->expr = gfc_build_addr_expr (type, se->expr);
4836 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4837 gcc_assert (se->string_length
4838 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4842 /* Generate code for assignment of scalar variables. Includes character
4843 strings and derived types with allocatable components.
4844 If you know that the LHS has no allocations, set dealloc to false. */
4847 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4848 bool l_is_temp, bool r_is_var, bool dealloc)
4854 gfc_init_block (&block);
4856 if (ts.type == BT_CHARACTER)
4861 if (lse->string_length != NULL_TREE)
4863 gfc_conv_string_parameter (lse);
4864 gfc_add_block_to_block (&block, &lse->pre);
4865 llen = lse->string_length;
4868 if (rse->string_length != NULL_TREE)
4870 gcc_assert (rse->string_length != NULL_TREE);
4871 gfc_conv_string_parameter (rse);
4872 gfc_add_block_to_block (&block, &rse->pre);
4873 rlen = rse->string_length;
4876 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4877 rse->expr, ts.kind);
4879 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4883 /* Are the rhs and the lhs the same? */
4886 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4887 gfc_build_addr_expr (NULL_TREE, lse->expr),
4888 gfc_build_addr_expr (NULL_TREE, rse->expr));
4889 cond = gfc_evaluate_now (cond, &lse->pre);
4892 /* Deallocate the lhs allocated components as long as it is not
4893 the same as the rhs. This must be done following the assignment
4894 to prevent deallocating data that could be used in the rhs
4896 if (!l_is_temp && dealloc)
4898 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4899 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4901 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4903 gfc_add_expr_to_block (&lse->post, tmp);
4906 gfc_add_block_to_block (&block, &rse->pre);
4907 gfc_add_block_to_block (&block, &lse->pre);
4909 gfc_add_modify (&block, lse->expr,
4910 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4912 /* Do a deep copy if the rhs is a variable, if it is not the
4916 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4917 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4919 gfc_add_expr_to_block (&block, tmp);
4922 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4924 gfc_add_block_to_block (&block, &lse->pre);
4925 gfc_add_block_to_block (&block, &rse->pre);
4926 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4927 gfc_add_modify (&block, lse->expr, tmp);
4931 gfc_add_block_to_block (&block, &lse->pre);
4932 gfc_add_block_to_block (&block, &rse->pre);
4934 gfc_add_modify (&block, lse->expr,
4935 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4938 gfc_add_block_to_block (&block, &lse->post);
4939 gfc_add_block_to_block (&block, &rse->post);
4941 return gfc_finish_block (&block);
4945 /* There are quite a lot of restrictions on the optimisation in using an
4946 array function assign without a temporary. */
4949 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
4952 bool seen_array_ref;
4954 gfc_symbol *sym = expr1->symtree->n.sym;
4956 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4957 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4960 /* Elemental functions are scalarized so that they don't need a
4961 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
4962 they would need special treatment in gfc_trans_arrayfunc_assign. */
4963 if (expr2->value.function.esym != NULL
4964 && expr2->value.function.esym->attr.elemental)
4967 /* Need a temporary if rhs is not FULL or a contiguous section. */
4968 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4971 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
4972 if (gfc_ref_needs_temporary_p (expr1->ref))
4975 /* Functions returning pointers need temporaries. */
4976 if (expr2->symtree->n.sym->attr.pointer
4977 || expr2->symtree->n.sym->attr.allocatable)
4980 /* Character array functions need temporaries unless the
4981 character lengths are the same. */
4982 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4984 if (expr1->ts.u.cl->length == NULL
4985 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4988 if (expr2->ts.u.cl->length == NULL
4989 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4992 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4993 expr2->ts.u.cl->length->value.integer) != 0)
4997 /* Check that no LHS component references appear during an array
4998 reference. This is needed because we do not have the means to
4999 span any arbitrary stride with an array descriptor. This check
5000 is not needed for the rhs because the function result has to be
5002 seen_array_ref = false;
5003 for (ref = expr1->ref; ref; ref = ref->next)
5005 if (ref->type == REF_ARRAY)
5006 seen_array_ref= true;
5007 else if (ref->type == REF_COMPONENT && seen_array_ref)
5011 /* Check for a dependency. */
5012 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5013 expr2->value.function.esym,
5014 expr2->value.function.actual,
5018 /* If we have reached here with an intrinsic function, we do not
5019 need a temporary. */
5020 if (expr2->value.function.isym)
5023 /* If the LHS is a dummy, we need a temporary if it is not
5025 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5028 /* A PURE function can unconditionally be called without a temporary. */
5029 if (expr2->value.function.esym != NULL
5030 && expr2->value.function.esym->attr.pure)
5033 /* TODO a function that could correctly be declared PURE but is not
5034 could do with returning false as well. */
5036 if (!sym->attr.use_assoc
5037 && !sym->attr.in_common
5038 && !sym->attr.pointer
5039 && !sym->attr.target
5040 && expr2->value.function.esym)
5042 /* A temporary is not needed if the function is not contained and
5043 the variable is local or host associated and not a pointer or
5045 if (!expr2->value.function.esym->attr.contained)
5048 /* A temporary is not needed if the lhs has never been host
5049 associated and the procedure is contained. */
5050 else if (!sym->attr.host_assoc)
5053 /* A temporary is not needed if the variable is local and not
5054 a pointer, a target or a result. */
5056 && expr2->value.function.esym->ns == sym->ns->parent)
5060 /* Default to temporary use. */
5065 /* Try to translate array(:) = func (...), where func is a transformational
5066 array function, without using a temporary. Returns NULL if this isn't the
5070 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5074 gfc_component *comp = NULL;
5076 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5079 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5081 gcc_assert (expr2->value.function.isym
5082 || (gfc_is_proc_ptr_comp (expr2, &comp)
5083 && comp && comp->attr.dimension)
5084 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5085 && expr2->value.function.esym->result->attr.dimension));
5087 ss = gfc_walk_expr (expr1);
5088 gcc_assert (ss != gfc_ss_terminator);
5089 gfc_init_se (&se, NULL);
5090 gfc_start_block (&se.pre);
5091 se.want_pointer = 1;
5093 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5095 if (expr1->ts.type == BT_DERIVED
5096 && expr1->ts.u.derived->attr.alloc_comp)
5099 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5101 gfc_add_expr_to_block (&se.pre, tmp);
5104 se.direct_byref = 1;
5105 se.ss = gfc_walk_expr (expr2);
5106 gcc_assert (se.ss != gfc_ss_terminator);
5107 gfc_conv_function_expr (&se, expr2);
5108 gfc_add_block_to_block (&se.pre, &se.post);
5110 return gfc_finish_block (&se.pre);
5114 /* Try to efficiently translate array(:) = 0. Return NULL if this
5118 gfc_trans_zero_assign (gfc_expr * expr)
5120 tree dest, len, type;
5124 sym = expr->symtree->n.sym;
5125 dest = gfc_get_symbol_decl (sym);
5127 type = TREE_TYPE (dest);
5128 if (POINTER_TYPE_P (type))
5129 type = TREE_TYPE (type);
5130 if (!GFC_ARRAY_TYPE_P (type))
5133 /* Determine the length of the array. */
5134 len = GFC_TYPE_ARRAY_SIZE (type);
5135 if (!len || TREE_CODE (len) != INTEGER_CST)
5138 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5139 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5140 fold_convert (gfc_array_index_type, tmp));
5142 /* If we are zeroing a local array avoid taking its address by emitting
5144 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5145 return build2 (MODIFY_EXPR, void_type_node,
5146 dest, build_constructor (TREE_TYPE (dest), NULL));
5148 /* Convert arguments to the correct types. */
5149 dest = fold_convert (pvoid_type_node, dest);
5150 len = fold_convert (size_type_node, len);
5152 /* Construct call to __builtin_memset. */
5153 tmp = build_call_expr_loc (input_location,
5154 built_in_decls[BUILT_IN_MEMSET],
5155 3, dest, integer_zero_node, len);
5156 return fold_convert (void_type_node, tmp);
5160 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5161 that constructs the call to __builtin_memcpy. */
5164 gfc_build_memcpy_call (tree dst, tree src, tree len)
5168 /* Convert arguments to the correct types. */
5169 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5170 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5172 dst = fold_convert (pvoid_type_node, dst);
5174 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5175 src = gfc_build_addr_expr (pvoid_type_node, src);
5177 src = fold_convert (pvoid_type_node, src);
5179 len = fold_convert (size_type_node, len);
5181 /* Construct call to __builtin_memcpy. */
5182 tmp = build_call_expr_loc (input_location,
5183 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5184 return fold_convert (void_type_node, tmp);
5188 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5189 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5190 source/rhs, both are gfc_full_array_ref_p which have been checked for
5194 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5196 tree dst, dlen, dtype;
5197 tree src, slen, stype;
5200 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5201 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5203 dtype = TREE_TYPE (dst);
5204 if (POINTER_TYPE_P (dtype))
5205 dtype = TREE_TYPE (dtype);
5206 stype = TREE_TYPE (src);
5207 if (POINTER_TYPE_P (stype))
5208 stype = TREE_TYPE (stype);
5210 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5213 /* Determine the lengths of the arrays. */
5214 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5215 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5217 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5218 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5219 fold_convert (gfc_array_index_type, tmp));
5221 slen = GFC_TYPE_ARRAY_SIZE (stype);
5222 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5224 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5225 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5226 fold_convert (gfc_array_index_type, tmp));
5228 /* Sanity check that they are the same. This should always be
5229 the case, as we should already have checked for conformance. */
5230 if (!tree_int_cst_equal (slen, dlen))
5233 return gfc_build_memcpy_call (dst, src, dlen);
5237 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5238 this can't be done. EXPR1 is the destination/lhs for which
5239 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5242 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5244 unsigned HOST_WIDE_INT nelem;
5250 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5254 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5255 dtype = TREE_TYPE (dst);
5256 if (POINTER_TYPE_P (dtype))
5257 dtype = TREE_TYPE (dtype);
5258 if (!GFC_ARRAY_TYPE_P (dtype))
5261 /* Determine the lengths of the array. */
5262 len = GFC_TYPE_ARRAY_SIZE (dtype);
5263 if (!len || TREE_CODE (len) != INTEGER_CST)
5266 /* Confirm that the constructor is the same size. */
5267 if (compare_tree_int (len, nelem) != 0)
5270 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5271 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5272 fold_convert (gfc_array_index_type, tmp));
5274 stype = gfc_typenode_for_spec (&expr2->ts);
5275 src = gfc_build_constant_array_constructor (expr2, stype);
5277 stype = TREE_TYPE (src);
5278 if (POINTER_TYPE_P (stype))
5279 stype = TREE_TYPE (stype);
5281 return gfc_build_memcpy_call (dst, src, len);
5285 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5286 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5287 init_flag indicates initialization expressions and dealloc that no
5288 deallocate prior assignment is needed (if in doubt, set true). */
5291 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5297 gfc_ss *lss_section;
5304 bool scalar_to_array;
5308 /* Assignment of the form lhs = rhs. */
5309 gfc_start_block (&block);
5311 gfc_init_se (&lse, NULL);
5312 gfc_init_se (&rse, NULL);
5315 lss = gfc_walk_expr (expr1);
5317 if (lss != gfc_ss_terminator)
5319 /* Allow the scalarizer to workshare array assignments. */
5320 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5321 ompws_flags |= OMPWS_SCALARIZER_WS;
5323 /* The assignment needs scalarization. */
5326 /* Find a non-scalar SS from the lhs. */
5327 while (lss_section != gfc_ss_terminator
5328 && lss_section->type != GFC_SS_SECTION)
5329 lss_section = lss_section->next;
5331 gcc_assert (lss_section != gfc_ss_terminator);
5333 /* Initialize the scalarizer. */
5334 gfc_init_loopinfo (&loop);
5337 rss = gfc_walk_expr (expr2);
5338 if (rss == gfc_ss_terminator)
5340 /* The rhs is scalar. Add a ss for the expression. */
5341 rss = gfc_get_ss ();
5342 rss->next = gfc_ss_terminator;
5343 rss->type = GFC_SS_SCALAR;
5346 /* Associate the SS with the loop. */
5347 gfc_add_ss_to_loop (&loop, lss);
5348 gfc_add_ss_to_loop (&loop, rss);
5350 /* Calculate the bounds of the scalarization. */
5351 gfc_conv_ss_startstride (&loop);
5352 /* Enable loop reversal. */
5353 for (n = 0; n < loop.dimen; n++)
5354 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5355 /* Resolve any data dependencies in the statement. */
5356 gfc_conv_resolve_dependencies (&loop, lss, rss);
5357 /* Setup the scalarizing loops. */
5358 gfc_conv_loop_setup (&loop, &expr2->where);
5360 /* Setup the gfc_se structures. */
5361 gfc_copy_loopinfo_to_se (&lse, &loop);
5362 gfc_copy_loopinfo_to_se (&rse, &loop);
5365 gfc_mark_ss_chain_used (rss, 1);
5366 if (loop.temp_ss == NULL)
5369 gfc_mark_ss_chain_used (lss, 1);
5373 lse.ss = loop.temp_ss;
5374 gfc_mark_ss_chain_used (lss, 3);
5375 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5378 /* Start the scalarized loop body. */
5379 gfc_start_scalarized_body (&loop, &body);
5382 gfc_init_block (&body);
5384 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5386 /* Translate the expression. */
5387 gfc_conv_expr (&rse, expr2);
5389 /* Stabilize a string length for temporaries. */
5390 if (expr2->ts.type == BT_CHARACTER)
5391 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5393 string_length = NULL_TREE;
5397 gfc_conv_tmp_array_ref (&lse);
5398 gfc_advance_se_ss_chain (&lse);
5399 if (expr2->ts.type == BT_CHARACTER)
5400 lse.string_length = string_length;
5403 gfc_conv_expr (&lse, expr1);
5405 /* Assignments of scalar derived types with allocatable components
5406 to arrays must be done with a deep copy and the rhs temporary
5407 must have its components deallocated afterwards. */
5408 scalar_to_array = (expr2->ts.type == BT_DERIVED
5409 && expr2->ts.u.derived->attr.alloc_comp
5410 && expr2->expr_type != EXPR_VARIABLE
5411 && !gfc_is_constant_expr (expr2)
5412 && expr1->rank && !expr2->rank);
5413 if (scalar_to_array && dealloc)
5415 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5416 gfc_add_expr_to_block (&loop.post, tmp);
5419 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5420 l_is_temp || init_flag,
5421 (expr2->expr_type == EXPR_VARIABLE)
5422 || scalar_to_array, dealloc);
5423 gfc_add_expr_to_block (&body, tmp);
5425 if (lss == gfc_ss_terminator)
5427 /* Use the scalar assignment as is. */
5428 gfc_add_block_to_block (&block, &body);
5432 gcc_assert (lse.ss == gfc_ss_terminator
5433 && rse.ss == gfc_ss_terminator);
5437 gfc_trans_scalarized_loop_boundary (&loop, &body);
5439 /* We need to copy the temporary to the actual lhs. */
5440 gfc_init_se (&lse, NULL);
5441 gfc_init_se (&rse, NULL);
5442 gfc_copy_loopinfo_to_se (&lse, &loop);
5443 gfc_copy_loopinfo_to_se (&rse, &loop);
5445 rse.ss = loop.temp_ss;
5448 gfc_conv_tmp_array_ref (&rse);
5449 gfc_advance_se_ss_chain (&rse);
5450 gfc_conv_expr (&lse, expr1);
5452 gcc_assert (lse.ss == gfc_ss_terminator
5453 && rse.ss == gfc_ss_terminator);
5455 if (expr2->ts.type == BT_CHARACTER)
5456 rse.string_length = string_length;
5458 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5459 false, false, dealloc);
5460 gfc_add_expr_to_block (&body, tmp);
5463 /* Generate the copying loops. */
5464 gfc_trans_scalarizing_loops (&loop, &body);
5466 /* Wrap the whole thing up. */
5467 gfc_add_block_to_block (&block, &loop.pre);
5468 gfc_add_block_to_block (&block, &loop.post);
5470 gfc_cleanup_loop (&loop);
5473 return gfc_finish_block (&block);
5477 /* Check whether EXPR is a copyable array. */
5480 copyable_array_p (gfc_expr * expr)
5482 if (expr->expr_type != EXPR_VARIABLE)
5485 /* First check it's an array. */
5486 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5489 if (!gfc_full_array_ref_p (expr->ref, NULL))
5492 /* Next check that it's of a simple enough type. */
5493 switch (expr->ts.type)
5505 return !expr->ts.u.derived->attr.alloc_comp;
5514 /* Translate an assignment. */
5517 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5522 /* Special case a single function returning an array. */
5523 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5525 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5530 /* Special case assigning an array to zero. */
5531 if (copyable_array_p (expr1)
5532 && is_zero_initializer_p (expr2))
5534 tmp = gfc_trans_zero_assign (expr1);
5539 /* Special case copying one array to another. */
5540 if (copyable_array_p (expr1)
5541 && copyable_array_p (expr2)
5542 && gfc_compare_types (&expr1->ts, &expr2->ts)
5543 && !gfc_check_dependency (expr1, expr2, 0))
5545 tmp = gfc_trans_array_copy (expr1, expr2);
5550 /* Special case initializing an array from a constant array constructor. */
5551 if (copyable_array_p (expr1)
5552 && expr2->expr_type == EXPR_ARRAY
5553 && gfc_compare_types (&expr1->ts, &expr2->ts))
5555 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5560 /* Fallback to the scalarizer to generate explicit loops. */
5561 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5565 gfc_trans_init_assign (gfc_code * code)
5567 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5571 gfc_trans_assign (gfc_code * code)
5573 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5577 /* Generate code to assign typebound procedures to a derived vtab. */
5578 void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
5585 tree cond = NULL_TREE;
5589 /* Point to the first procedure pointer. */
5590 cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
5592 seen_extends = (cmp != NULL);
5594 vtb = gfc_get_symbol_decl (vtab);
5601 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5602 vtb, cmp->backend_decl, NULL_TREE);
5603 cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
5604 build_int_cst (TREE_TYPE (ctree), 0));
5608 cmp = vtab->ts.u.derived->components;
5611 gfc_init_block (&body);
5612 for (; cmp; cmp = cmp->next)
5614 gfc_symbol *target = NULL;
5616 /* Generic procedure - build its vtab. */
5617 if (cmp->ts.type == BT_DERIVED && !cmp->tb)
5619 gfc_symbol *vt = cmp->ts.interface;
5623 /* Use association loses the interface. Obtain the vtab
5625 char name[2 * GFC_MAX_SYMBOL_LEN + 8];
5626 sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
5628 gfc_find_symbol (name, vtab->ns, 0, &vt);
5633 gfc_trans_assign_vtab_procs (&body, dt, vt);
5634 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5635 vtb, cmp->backend_decl, NULL_TREE);
5636 proc = gfc_get_symbol_decl (vt);
5637 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5638 gfc_add_modify (&body, ctree, proc);
5642 /* This is required when typebound generic procedures are called
5643 with derived type targets. The specific procedures do not get
5644 added to the vtype, which remains "empty". */
5645 if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
5646 target = cmp->tb->u.specific->n.sym;
5650 st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
5651 if (st->n.tb && st->n.tb->u.specific)
5652 target = st->n.tb->u.specific->n.sym;
5658 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5659 vtb, cmp->backend_decl, NULL_TREE);
5660 proc = gfc_get_symbol_decl (target);
5661 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5662 gfc_add_modify (&body, ctree, proc);
5665 proc = gfc_finish_block (&body);
5668 proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
5670 gfc_add_expr_to_block (block, proc);
5674 /* Special case for initializing a CLASS variable on allocation.
5675 A MEMCPY is needed to copy the full data of the dynamic type,
5676 which may be different from the declared type. */
5679 gfc_trans_class_init_assign (gfc_code *code)
5685 gfc_start_block (&block);
5687 gfc_init_se (&dst, NULL);
5688 gfc_init_se (&src, NULL);
5689 gfc_add_component_ref (code->expr1, "$data");
5690 gfc_conv_expr (&dst, code->expr1);
5691 gfc_conv_expr (&src, code->expr2);
5692 gfc_add_block_to_block (&block, &src.pre);
5693 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5694 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5695 gfc_add_expr_to_block (&block, tmp);
5697 return gfc_finish_block (&block);
5701 /* Translate an assignment to a CLASS object
5702 (pointer or ordinary assignment). */
5705 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5712 gfc_start_block (&block);
5714 if (expr2->ts.type != BT_CLASS)
5716 /* Insert an additional assignment which sets the '$vptr' field. */
5717 lhs = gfc_copy_expr (expr1);
5718 gfc_add_component_ref (lhs, "$vptr");
5719 if (expr2->ts.type == BT_DERIVED)
5723 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5725 gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
5726 rhs = gfc_get_expr ();
5727 rhs->expr_type = EXPR_VARIABLE;
5728 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5732 else if (expr2->expr_type == EXPR_NULL)
5733 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5737 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5738 gfc_add_expr_to_block (&block, tmp);
5740 gfc_free_expr (lhs);
5741 gfc_free_expr (rhs);
5744 /* Do the actual CLASS assignment. */
5745 if (expr2->ts.type == BT_CLASS)
5748 gfc_add_component_ref (expr1, "$data");
5750 if (op == EXEC_ASSIGN)
5751 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5752 else if (op == EXEC_POINTER_ASSIGN)
5753 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5757 gfc_add_expr_to_block (&block, tmp);
5759 return gfc_finish_block (&block);