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"
34 #include "langhooks.h"
38 #include "constructor.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "dependency.h"
47 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
48 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
51 /* Copy the scalarization loop variables. */
54 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
57 dest->loop = src->loop;
61 /* Initialize a simple expression holder.
63 Care must be taken when multiple se are created with the same parent.
64 The child se must be kept in sync. The easiest way is to delay creation
65 of a child se until after after the previous se has been translated. */
68 gfc_init_se (gfc_se * se, gfc_se * parent)
70 memset (se, 0, sizeof (gfc_se));
71 gfc_init_block (&se->pre);
72 gfc_init_block (&se->post);
77 gfc_copy_se_loopvars (se, parent);
81 /* Advances to the next SS in the chain. Use this rather than setting
82 se->ss = se->ss->next because all the parents needs to be kept in sync.
86 gfc_advance_se_ss_chain (gfc_se * se)
90 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
93 /* Walk down the parent chain. */
96 /* Simple consistency check. */
97 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
106 /* Ensures the result of the expression as either a temporary variable
107 or a constant so that it can be used repeatedly. */
110 gfc_make_safe_expr (gfc_se * se)
114 if (CONSTANT_CLASS_P (se->expr))
117 /* We need a temporary for this result. */
118 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
119 gfc_add_modify (&se->pre, var, se->expr);
124 /* Return an expression which determines if a dummy parameter is present.
125 Also used for arguments to procedures with multiple entry points. */
128 gfc_conv_expr_present (gfc_symbol * sym)
132 gcc_assert (sym->attr.dummy);
134 decl = gfc_get_symbol_decl (sym);
135 if (TREE_CODE (decl) != PARM_DECL)
137 /* Array parameters use a temporary descriptor, we want the real
139 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
140 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
141 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
143 return fold_build2 (NE_EXPR, boolean_type_node, decl,
144 fold_convert (TREE_TYPE (decl), null_pointer_node));
148 /* Converts a missing, dummy argument into a null or zero. */
151 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
156 present = gfc_conv_expr_present (arg->symtree->n.sym);
160 /* Create a temporary and convert it to the correct type. */
161 tmp = gfc_get_int_type (kind);
162 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
165 /* Test for a NULL value. */
166 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
167 fold_convert (TREE_TYPE (tmp), integer_one_node));
168 tmp = gfc_evaluate_now (tmp, &se->pre);
169 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
173 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
174 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
175 tmp = gfc_evaluate_now (tmp, &se->pre);
179 if (ts.type == BT_CHARACTER)
181 tmp = build_int_cst (gfc_charlen_type_node, 0);
182 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
183 present, se->string_length, tmp);
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->string_length = tmp;
191 /* Get the character length of an expression, looking through gfc_refs
195 gfc_get_expr_charlen (gfc_expr *e)
200 gcc_assert (e->expr_type == EXPR_VARIABLE
201 && e->ts.type == BT_CHARACTER);
203 length = NULL; /* To silence compiler warning. */
205 if (is_subref_array (e) && e->ts.u.cl->length)
208 gfc_init_se (&tmpse, NULL);
209 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
210 e->ts.u.cl->backend_decl = tmpse.expr;
214 /* First candidate: if the variable is of type CHARACTER, the
215 expression's length could be the length of the character
217 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
218 length = e->symtree->n.sym->ts.u.cl->backend_decl;
220 /* Look through the reference chain for component references. */
221 for (r = e->ref; r; r = r->next)
226 if (r->u.c.component->ts.type == BT_CHARACTER)
227 length = r->u.c.component->ts.u.cl->backend_decl;
235 /* We should never got substring references here. These will be
236 broken down by the scalarizer. */
242 gcc_assert (length != NULL);
247 /* For each character array constructor subexpression without a ts.u.cl->length,
248 replace it by its first element (if there aren't any elements, the length
249 should already be set to zero). */
252 flatten_array_ctors_without_strlen (gfc_expr* e)
254 gfc_actual_arglist* arg;
260 switch (e->expr_type)
264 flatten_array_ctors_without_strlen (e->value.op.op1);
265 flatten_array_ctors_without_strlen (e->value.op.op2);
269 /* TODO: Implement as with EXPR_FUNCTION when needed. */
273 for (arg = e->value.function.actual; arg; arg = arg->next)
274 flatten_array_ctors_without_strlen (arg->expr);
279 /* We've found what we're looking for. */
280 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
285 gcc_assert (e->value.constructor);
287 c = gfc_constructor_first (e->value.constructor);
291 flatten_array_ctors_without_strlen (new_expr);
292 gfc_replace_expr (e, new_expr);
296 /* Otherwise, fall through to handle constructor elements. */
298 for (c = gfc_constructor_first (e->value.constructor);
299 c; c = gfc_constructor_next (c))
300 flatten_array_ctors_without_strlen (c->expr);
310 /* Generate code to initialize a string length variable. Returns the
311 value. For array constructors, cl->length might be NULL and in this case,
312 the first element of the constructor is needed. expr is the original
313 expression so we can access it but can be NULL if this is not needed. */
316 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
320 gfc_init_se (&se, NULL);
322 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
323 "flatten" array constructors by taking their first element; all elements
324 should be the same length or a cl->length should be present. */
330 expr_flat = gfc_copy_expr (expr);
331 flatten_array_ctors_without_strlen (expr_flat);
332 gfc_resolve_expr (expr_flat);
334 gfc_conv_expr (&se, expr_flat);
335 gfc_add_block_to_block (pblock, &se.pre);
336 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
338 gfc_free_expr (expr_flat);
342 /* Convert cl->length. */
344 gcc_assert (cl->length);
346 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
347 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
348 build_int_cst (gfc_charlen_type_node, 0));
349 gfc_add_block_to_block (pblock, &se.pre);
351 if (cl->backend_decl)
352 gfc_add_modify (pblock, cl->backend_decl, se.expr);
354 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
359 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
360 const char *name, locus *where)
369 type = gfc_get_character_type (kind, ref->u.ss.length);
370 type = build_pointer_type (type);
372 gfc_init_se (&start, se);
373 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
374 gfc_add_block_to_block (&se->pre, &start.pre);
376 if (integer_onep (start.expr))
377 gfc_conv_string_parameter (se);
382 /* Avoid multiple evaluation of substring start. */
383 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
384 start.expr = gfc_evaluate_now (start.expr, &se->pre);
386 /* Change the start of the string. */
387 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
390 tmp = build_fold_indirect_ref_loc (input_location,
392 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
393 se->expr = gfc_build_addr_expr (type, tmp);
396 /* Length = end + 1 - start. */
397 gfc_init_se (&end, se);
398 if (ref->u.ss.end == NULL)
399 end.expr = se->string_length;
402 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
403 gfc_add_block_to_block (&se->pre, &end.pre);
407 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
408 end.expr = gfc_evaluate_now (end.expr, &se->pre);
410 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
412 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
413 start.expr, end.expr);
415 /* Check lower bound. */
416 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
417 build_int_cst (gfc_charlen_type_node, 1));
418 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
421 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
422 "is less than one", name);
424 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
426 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
427 fold_convert (long_integer_type_node,
431 /* Check upper bound. */
432 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
434 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
437 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
438 "exceeds string length (%%ld)", name);
440 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
441 "exceeds string length (%%ld)");
442 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
443 fold_convert (long_integer_type_node, end.expr),
444 fold_convert (long_integer_type_node,
449 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
450 end.expr, start.expr);
451 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
452 build_int_cst (gfc_charlen_type_node, 1), tmp);
453 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
454 build_int_cst (gfc_charlen_type_node, 0));
455 se->string_length = tmp;
459 /* Convert a derived type component reference. */
462 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
469 c = ref->u.c.component;
471 gcc_assert (c->backend_decl);
473 field = c->backend_decl;
474 gcc_assert (TREE_CODE (field) == FIELD_DECL);
476 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
480 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
482 tmp = c->ts.u.cl->backend_decl;
483 /* Components must always be constant length. */
484 gcc_assert (tmp && INTEGER_CST_P (tmp));
485 se->string_length = tmp;
488 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
489 && c->ts.type != BT_CHARACTER)
490 || c->attr.proc_pointer)
491 se->expr = build_fold_indirect_ref_loc (input_location,
496 /* This function deals with component references to components of the
497 parent type for derived type extensons. */
499 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
507 c = ref->u.c.component;
509 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
510 parent.type = REF_COMPONENT;
513 parent.u.c.component = dt->components;
515 if (dt->backend_decl == NULL)
516 gfc_get_derived_type (dt);
518 if (dt->attr.extension && dt->components)
520 if (dt->attr.is_class)
521 cmp = dt->components;
523 cmp = dt->components->next;
524 /* Return if the component is not in the parent type. */
525 for (; cmp; cmp = cmp->next)
526 if (strcmp (c->name, cmp->name) == 0)
529 /* Otherwise build the reference and call self. */
530 gfc_conv_component_ref (se, &parent);
531 parent.u.c.sym = dt->components->ts.u.derived;
532 parent.u.c.component = c;
533 conv_parent_component_references (se, &parent);
537 /* Return the contents of a variable. Also handles reference/pointer
538 variables (all Fortran pointer references are implicit). */
541 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
548 bool alternate_entry;
551 sym = expr->symtree->n.sym;
554 /* Check that something hasn't gone horribly wrong. */
555 gcc_assert (se->ss != gfc_ss_terminator);
556 gcc_assert (se->ss->expr == expr);
558 /* A scalarized term. We already know the descriptor. */
559 se->expr = se->ss->data.info.descriptor;
560 se->string_length = se->ss->string_length;
561 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
562 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
567 tree se_expr = NULL_TREE;
569 se->expr = gfc_get_symbol_decl (sym);
571 /* Deal with references to a parent results or entries by storing
572 the current_function_decl and moving to the parent_decl. */
573 return_value = sym->attr.function && sym->result == sym;
574 alternate_entry = sym->attr.function && sym->attr.entry
575 && sym->result == sym;
576 entry_master = sym->attr.result
577 && sym->ns->proc_name->attr.entry_master
578 && !gfc_return_by_reference (sym->ns->proc_name);
579 parent_decl = DECL_CONTEXT (current_function_decl);
581 if ((se->expr == parent_decl && return_value)
582 || (sym->ns && sym->ns->proc_name
584 && sym->ns->proc_name->backend_decl == parent_decl
585 && (alternate_entry || entry_master)))
590 /* Special case for assigning the return value of a function.
591 Self recursive functions must have an explicit return value. */
592 if (return_value && (se->expr == current_function_decl || parent_flag))
593 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
595 /* Similarly for alternate entry points. */
596 else if (alternate_entry
597 && (sym->ns->proc_name->backend_decl == current_function_decl
600 gfc_entry_list *el = NULL;
602 for (el = sym->ns->entries; el; el = el->next)
605 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
610 else if (entry_master
611 && (sym->ns->proc_name->backend_decl == current_function_decl
613 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
618 /* Procedure actual arguments. */
619 else if (sym->attr.flavor == FL_PROCEDURE
620 && se->expr != current_function_decl)
622 if (!sym->attr.dummy && !sym->attr.proc_pointer)
624 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
625 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
631 /* Dereference the expression, where needed. Since characters
632 are entirely different from other types, they are treated
634 if (sym->ts.type == BT_CHARACTER)
636 /* Dereference character pointer dummy arguments
638 if ((sym->attr.pointer || sym->attr.allocatable)
640 || sym->attr.function
641 || sym->attr.result))
642 se->expr = build_fold_indirect_ref_loc (input_location,
646 else if (!sym->attr.value)
648 /* Dereference non-character scalar dummy arguments. */
649 if (sym->attr.dummy && !sym->attr.dimension)
650 se->expr = build_fold_indirect_ref_loc (input_location,
653 /* Dereference scalar hidden result. */
654 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
655 && (sym->attr.function || sym->attr.result)
656 && !sym->attr.dimension && !sym->attr.pointer
657 && !sym->attr.always_explicit)
658 se->expr = build_fold_indirect_ref_loc (input_location,
661 /* Dereference non-character pointer variables.
662 These must be dummies, results, or scalars. */
663 if ((sym->attr.pointer || sym->attr.allocatable)
665 || sym->attr.function
667 || !sym->attr.dimension))
668 se->expr = build_fold_indirect_ref_loc (input_location,
675 /* For character variables, also get the length. */
676 if (sym->ts.type == BT_CHARACTER)
678 /* If the character length of an entry isn't set, get the length from
679 the master function instead. */
680 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
681 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
683 se->string_length = sym->ts.u.cl->backend_decl;
684 gcc_assert (se->string_length);
692 /* Return the descriptor if that's what we want and this is an array
693 section reference. */
694 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
696 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
697 /* Return the descriptor for array pointers and allocations. */
699 && ref->next == NULL && (se->descriptor_only))
702 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
703 /* Return a pointer to an element. */
707 if (ref->u.c.sym->attr.extension)
708 conv_parent_component_references (se, ref);
710 gfc_conv_component_ref (se, ref);
714 gfc_conv_substring (se, ref, expr->ts.kind,
715 expr->symtree->name, &expr->where);
724 /* Pointer assignment, allocation or pass by reference. Arrays are handled
726 if (se->want_pointer)
728 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
729 gfc_conv_string_parameter (se);
731 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
736 /* Unary ops are easy... Or they would be if ! was a valid op. */
739 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
744 gcc_assert (expr->ts.type != BT_CHARACTER);
745 /* Initialize the operand. */
746 gfc_init_se (&operand, se);
747 gfc_conv_expr_val (&operand, expr->value.op.op1);
748 gfc_add_block_to_block (&se->pre, &operand.pre);
750 type = gfc_typenode_for_spec (&expr->ts);
752 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
753 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
754 All other unary operators have an equivalent GIMPLE unary operator. */
755 if (code == TRUTH_NOT_EXPR)
756 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
757 build_int_cst (type, 0));
759 se->expr = fold_build1 (code, type, operand.expr);
763 /* Expand power operator to optimal multiplications when a value is raised
764 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
765 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
766 Programming", 3rd Edition, 1998. */
768 /* This code is mostly duplicated from expand_powi in the backend.
769 We establish the "optimal power tree" lookup table with the defined size.
770 The items in the table are the exponents used to calculate the index
771 exponents. Any integer n less than the value can get an "addition chain",
772 with the first node being one. */
773 #define POWI_TABLE_SIZE 256
775 /* The table is from builtins.c. */
776 static const unsigned char powi_table[POWI_TABLE_SIZE] =
778 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
779 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
780 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
781 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
782 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
783 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
784 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
785 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
786 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
787 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
788 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
789 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
790 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
791 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
792 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
793 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
794 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
795 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
796 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
797 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
798 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
799 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
800 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
801 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
802 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
803 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
804 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
805 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
806 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
807 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
808 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
809 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
812 /* If n is larger than lookup table's max index, we use the "window
814 #define POWI_WINDOW_SIZE 3
816 /* Recursive function to expand the power operator. The temporary
817 values are put in tmpvar. The function returns tmpvar[1] ** n. */
819 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
826 if (n < POWI_TABLE_SIZE)
831 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
832 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
836 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
837 op0 = gfc_conv_powi (se, n - digit, tmpvar);
838 op1 = gfc_conv_powi (se, digit, tmpvar);
842 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
846 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
847 tmp = gfc_evaluate_now (tmp, &se->pre);
849 if (n < POWI_TABLE_SIZE)
856 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
857 return 1. Else return 0 and a call to runtime library functions
858 will have to be built. */
860 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
865 tree vartmp[POWI_TABLE_SIZE];
867 unsigned HOST_WIDE_INT n;
870 /* If exponent is too large, we won't expand it anyway, so don't bother
871 with large integer values. */
872 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
875 m = double_int_to_shwi (TREE_INT_CST (rhs));
876 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
877 of the asymmetric range of the integer type. */
878 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
880 type = TREE_TYPE (lhs);
881 sgn = tree_int_cst_sgn (rhs);
883 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
884 || optimize_size) && (m > 2 || m < -1))
890 se->expr = gfc_build_const (type, integer_one_node);
894 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
895 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
897 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
898 lhs, build_int_cst (TREE_TYPE (lhs), -1));
899 cond = fold_build2 (EQ_EXPR, boolean_type_node,
900 lhs, build_int_cst (TREE_TYPE (lhs), 1));
903 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
906 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
907 se->expr = fold_build3 (COND_EXPR, type,
908 tmp, build_int_cst (type, 1),
909 build_int_cst (type, 0));
913 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
914 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
915 build_int_cst (type, 0));
916 se->expr = fold_build3 (COND_EXPR, type,
917 cond, build_int_cst (type, 1), tmp);
921 memset (vartmp, 0, sizeof (vartmp));
925 tmp = gfc_build_const (type, integer_one_node);
926 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
929 se->expr = gfc_conv_powi (se, n, vartmp);
935 /* Power op (**). Constant integer exponent has special handling. */
938 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
940 tree gfc_int4_type_node;
947 gfc_init_se (&lse, se);
948 gfc_conv_expr_val (&lse, expr->value.op.op1);
949 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
950 gfc_add_block_to_block (&se->pre, &lse.pre);
952 gfc_init_se (&rse, se);
953 gfc_conv_expr_val (&rse, expr->value.op.op2);
954 gfc_add_block_to_block (&se->pre, &rse.pre);
956 if (expr->value.op.op2->ts.type == BT_INTEGER
957 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
958 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
961 gfc_int4_type_node = gfc_get_int_type (4);
963 kind = expr->value.op.op1->ts.kind;
964 switch (expr->value.op.op2->ts.type)
967 ikind = expr->value.op.op2->ts.kind;
972 rse.expr = convert (gfc_int4_type_node, rse.expr);
994 if (expr->value.op.op1->ts.type == BT_INTEGER)
995 lse.expr = convert (gfc_int4_type_node, lse.expr);
1020 switch (expr->value.op.op1->ts.type)
1023 if (kind == 3) /* Case 16 was not handled properly above. */
1025 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1029 /* Use builtins for real ** int4. */
1035 fndecl = built_in_decls[BUILT_IN_POWIF];
1039 fndecl = built_in_decls[BUILT_IN_POWI];
1044 fndecl = built_in_decls[BUILT_IN_POWIL];
1052 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1056 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1068 fndecl = built_in_decls[BUILT_IN_POWF];
1071 fndecl = built_in_decls[BUILT_IN_POW];
1075 fndecl = built_in_decls[BUILT_IN_POWL];
1086 fndecl = built_in_decls[BUILT_IN_CPOWF];
1089 fndecl = built_in_decls[BUILT_IN_CPOW];
1093 fndecl = built_in_decls[BUILT_IN_CPOWL];
1105 se->expr = build_call_expr_loc (input_location,
1106 fndecl, 2, lse.expr, rse.expr);
1110 /* Generate code to allocate a string temporary. */
1113 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1118 gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
1120 if (gfc_can_put_var_on_stack (len))
1122 /* Create a temporary variable to hold the result. */
1123 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1124 build_int_cst (gfc_charlen_type_node, 1));
1125 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1127 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1128 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1130 tmp = build_array_type (TREE_TYPE (type), tmp);
1132 var = gfc_create_var (tmp, "str");
1133 var = gfc_build_addr_expr (type, var);
1137 /* Allocate a temporary to hold the result. */
1138 var = gfc_create_var (type, "pstr");
1139 tmp = gfc_call_malloc (&se->pre, type,
1140 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1141 fold_convert (TREE_TYPE (len),
1142 TYPE_SIZE (type))));
1143 gfc_add_modify (&se->pre, var, tmp);
1145 /* Free the temporary afterwards. */
1146 tmp = gfc_call_free (convert (pvoid_type_node, var));
1147 gfc_add_expr_to_block (&se->post, tmp);
1154 /* Handle a string concatenation operation. A temporary will be allocated to
1158 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1161 tree len, type, var, tmp, fndecl;
1163 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1164 && expr->value.op.op2->ts.type == BT_CHARACTER);
1165 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1167 gfc_init_se (&lse, se);
1168 gfc_conv_expr (&lse, expr->value.op.op1);
1169 gfc_conv_string_parameter (&lse);
1170 gfc_init_se (&rse, se);
1171 gfc_conv_expr (&rse, expr->value.op.op2);
1172 gfc_conv_string_parameter (&rse);
1174 gfc_add_block_to_block (&se->pre, &lse.pre);
1175 gfc_add_block_to_block (&se->pre, &rse.pre);
1177 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1178 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1179 if (len == NULL_TREE)
1181 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1182 lse.string_length, rse.string_length);
1185 type = build_pointer_type (type);
1187 var = gfc_conv_string_tmp (se, type, len);
1189 /* Do the actual concatenation. */
1190 if (expr->ts.kind == 1)
1191 fndecl = gfor_fndecl_concat_string;
1192 else if (expr->ts.kind == 4)
1193 fndecl = gfor_fndecl_concat_string_char4;
1197 tmp = build_call_expr_loc (input_location,
1198 fndecl, 6, len, var, lse.string_length, lse.expr,
1199 rse.string_length, rse.expr);
1200 gfc_add_expr_to_block (&se->pre, tmp);
1202 /* Add the cleanup for the operands. */
1203 gfc_add_block_to_block (&se->pre, &rse.post);
1204 gfc_add_block_to_block (&se->pre, &lse.post);
1207 se->string_length = len;
1210 /* Translates an op expression. Common (binary) cases are handled by this
1211 function, others are passed on. Recursion is used in either case.
1212 We use the fact that (op1.ts == op2.ts) (except for the power
1214 Operators need no special handling for scalarized expressions as long as
1215 they call gfc_conv_simple_val to get their operands.
1216 Character strings get special handling. */
1219 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1221 enum tree_code code;
1230 switch (expr->value.op.op)
1232 case INTRINSIC_PARENTHESES:
1233 if ((expr->ts.type == BT_REAL
1234 || expr->ts.type == BT_COMPLEX)
1235 && gfc_option.flag_protect_parens)
1237 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1238 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1243 case INTRINSIC_UPLUS:
1244 gfc_conv_expr (se, expr->value.op.op1);
1247 case INTRINSIC_UMINUS:
1248 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1252 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1255 case INTRINSIC_PLUS:
1259 case INTRINSIC_MINUS:
1263 case INTRINSIC_TIMES:
1267 case INTRINSIC_DIVIDE:
1268 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1269 an integer, we must round towards zero, so we use a
1271 if (expr->ts.type == BT_INTEGER)
1272 code = TRUNC_DIV_EXPR;
1277 case INTRINSIC_POWER:
1278 gfc_conv_power_op (se, expr);
1281 case INTRINSIC_CONCAT:
1282 gfc_conv_concat_op (se, expr);
1286 code = TRUTH_ANDIF_EXPR;
1291 code = TRUTH_ORIF_EXPR;
1295 /* EQV and NEQV only work on logicals, but since we represent them
1296 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1298 case INTRINSIC_EQ_OS:
1306 case INTRINSIC_NE_OS:
1307 case INTRINSIC_NEQV:
1314 case INTRINSIC_GT_OS:
1321 case INTRINSIC_GE_OS:
1328 case INTRINSIC_LT_OS:
1335 case INTRINSIC_LE_OS:
1341 case INTRINSIC_USER:
1342 case INTRINSIC_ASSIGN:
1343 /* These should be converted into function calls by the frontend. */
1347 fatal_error ("Unknown intrinsic op");
1351 /* The only exception to this is **, which is handled separately anyway. */
1352 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1354 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1358 gfc_init_se (&lse, se);
1359 gfc_conv_expr (&lse, expr->value.op.op1);
1360 gfc_add_block_to_block (&se->pre, &lse.pre);
1363 gfc_init_se (&rse, se);
1364 gfc_conv_expr (&rse, expr->value.op.op2);
1365 gfc_add_block_to_block (&se->pre, &rse.pre);
1369 gfc_conv_string_parameter (&lse);
1370 gfc_conv_string_parameter (&rse);
1372 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1373 rse.string_length, rse.expr,
1374 expr->value.op.op1->ts.kind);
1375 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1376 gfc_add_block_to_block (&lse.post, &rse.post);
1379 type = gfc_typenode_for_spec (&expr->ts);
1383 /* The result of logical ops is always boolean_type_node. */
1384 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1385 se->expr = convert (type, tmp);
1388 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1390 /* Add the post blocks. */
1391 gfc_add_block_to_block (&se->post, &rse.post);
1392 gfc_add_block_to_block (&se->post, &lse.post);
1395 /* If a string's length is one, we convert it to a single character. */
1398 string_to_single_character (tree len, tree str, int kind)
1400 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1402 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1403 && TREE_INT_CST_HIGH (len) == 0)
1405 str = fold_convert (gfc_get_pchar_type (kind), str);
1406 return build_fold_indirect_ref_loc (input_location,
1415 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1418 if (sym->backend_decl)
1420 /* This becomes the nominal_type in
1421 function.c:assign_parm_find_data_types. */
1422 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1423 /* This becomes the passed_type in
1424 function.c:assign_parm_find_data_types. C promotes char to
1425 integer for argument passing. */
1426 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1428 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1433 /* If we have a constant character expression, make it into an
1435 if ((*expr)->expr_type == EXPR_CONSTANT)
1440 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1441 (int)(*expr)->value.character.string[0]);
1442 if ((*expr)->ts.kind != gfc_c_int_kind)
1444 /* The expr needs to be compatible with a C int. If the
1445 conversion fails, then the 2 causes an ICE. */
1446 ts.type = BT_INTEGER;
1447 ts.kind = gfc_c_int_kind;
1448 gfc_convert_type (*expr, &ts, 2);
1451 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1453 if ((*expr)->ref == NULL)
1455 se->expr = string_to_single_character
1456 (build_int_cst (integer_type_node, 1),
1457 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1459 ((*expr)->symtree->n.sym)),
1464 gfc_conv_variable (se, *expr);
1465 se->expr = string_to_single_character
1466 (build_int_cst (integer_type_node, 1),
1467 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1476 /* Compare two strings. If they are all single characters, the result is the
1477 subtraction of them. Otherwise, we build a library call. */
1480 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1486 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1487 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1489 sc1 = string_to_single_character (len1, str1, kind);
1490 sc2 = string_to_single_character (len2, str2, kind);
1492 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1494 /* Deal with single character specially. */
1495 sc1 = fold_convert (integer_type_node, sc1);
1496 sc2 = fold_convert (integer_type_node, sc2);
1497 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1501 /* Build a call for the comparison. */
1505 fndecl = gfor_fndecl_compare_string;
1507 fndecl = gfor_fndecl_compare_string_char4;
1511 tmp = build_call_expr_loc (input_location,
1512 fndecl, 4, len1, str1, len2, str2);
1519 /* Return the backend_decl for a procedure pointer component. */
1522 get_proc_ptr_comp (gfc_expr *e)
1526 gfc_init_se (&comp_se, NULL);
1527 e2 = gfc_copy_expr (e);
1528 e2->expr_type = EXPR_VARIABLE;
1529 gfc_conv_expr (&comp_se, e2);
1531 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1535 /* Select a class typebound procedure at runtime. */
1537 select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
1538 tree declared, gfc_expr *expr)
1545 gfc_class_esym_list *next_elist, *tmp_elist;
1548 /* Convert the hash expression. */
1549 gfc_init_se (&tmpse, NULL);
1550 gfc_conv_expr (&tmpse, elist->hash_value);
1551 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1552 hash = gfc_evaluate_now (tmpse.expr, &se->pre);
1553 gfc_add_block_to_block (&se->post, &tmpse.post);
1555 /* Fix the function type to be that of the declared type method. */
1556 declared = gfc_create_var (TREE_TYPE (declared), "method");
1558 end_label = gfc_build_label_decl (NULL_TREE);
1560 gfc_init_block (&body);
1562 /* Go through the list of extensions. */
1563 for (; elist; elist = next_elist)
1565 /* This case has already been added. */
1566 if (elist->derived == NULL)
1569 /* Skip abstract base types. */
1570 if (elist->derived->attr.abstract)
1573 /* Run through the chain picking up all the cases that call the
1576 for (; elist; elist = elist->next)
1580 if (elist->esym != tmp_elist->esym)
1583 cval = build_int_cst (TREE_TYPE (hash),
1584 elist->derived->hash_value);
1585 /* Build a label for the hash value. */
1586 label = gfc_build_label_decl (NULL_TREE);
1587 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1588 cval, NULL_TREE, label);
1589 gfc_add_expr_to_block (&body, tmp);
1591 /* Null the reference the derived type so that this case is
1593 elist->derived = NULL;
1598 /* Get a pointer to the procedure, */
1599 tmp = gfc_get_symbol_decl (elist->esym);
1600 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1602 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1603 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1606 /* Assign the pointer to the appropriate procedure. */
1607 gfc_add_modify (&body, declared,
1608 fold_convert (TREE_TYPE (declared), tmp));
1610 /* Break to the end of the construct. */
1611 tmp = build1_v (GOTO_EXPR, end_label);
1612 gfc_add_expr_to_block (&body, tmp);
1614 /* Free the elists as we go; freeing them in gfc_free_expr causes
1615 segfaults because it occurs too early and too often. */
1617 next_elist = elist->next;
1618 if (elist->hash_value)
1619 gfc_free_expr (elist->hash_value);
1624 /* Default is an error. */
1625 label = gfc_build_label_decl (NULL_TREE);
1626 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1627 NULL_TREE, NULL_TREE, label);
1628 gfc_add_expr_to_block (&body, tmp);
1629 tmp = gfc_trans_runtime_error (true, &expr->where,
1630 "internal error: bad hash value in dynamic dispatch");
1631 gfc_add_expr_to_block (&body, tmp);
1633 /* Write the switch expression. */
1634 tmp = gfc_finish_block (&body);
1635 tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
1636 gfc_add_expr_to_block (&se->pre, tmp);
1638 tmp = build1_v (LABEL_EXPR, end_label);
1639 gfc_add_expr_to_block (&se->pre, tmp);
1641 se->expr = declared;
1647 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1651 if (expr && expr->symtree
1652 && expr->value.function.class_esym)
1654 if (!sym->backend_decl)
1655 sym->backend_decl = gfc_get_extern_function_decl (sym);
1657 tmp = sym->backend_decl;
1659 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1661 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1662 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1665 select_class_proc (se, expr->value.function.class_esym,
1670 if (gfc_is_proc_ptr_comp (expr, NULL))
1671 tmp = get_proc_ptr_comp (expr);
1672 else if (sym->attr.dummy)
1674 tmp = gfc_get_symbol_decl (sym);
1675 if (sym->attr.proc_pointer)
1676 tmp = build_fold_indirect_ref_loc (input_location,
1678 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1679 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1683 if (!sym->backend_decl)
1684 sym->backend_decl = gfc_get_extern_function_decl (sym);
1686 tmp = sym->backend_decl;
1688 if (sym->attr.cray_pointee)
1690 /* TODO - make the cray pointee a pointer to a procedure,
1691 assign the pointer to it and use it for the call. This
1693 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1694 gfc_get_symbol_decl (sym->cp_pointer));
1695 tmp = gfc_evaluate_now (tmp, &se->pre);
1698 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1700 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1701 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1708 /* Initialize MAPPING. */
1711 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1713 mapping->syms = NULL;
1714 mapping->charlens = NULL;
1718 /* Free all memory held by MAPPING (but not MAPPING itself). */
1721 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1723 gfc_interface_sym_mapping *sym;
1724 gfc_interface_sym_mapping *nextsym;
1726 gfc_charlen *nextcl;
1728 for (sym = mapping->syms; sym; sym = nextsym)
1730 nextsym = sym->next;
1731 sym->new_sym->n.sym->formal = NULL;
1732 gfc_free_symbol (sym->new_sym->n.sym);
1733 gfc_free_expr (sym->expr);
1734 gfc_free (sym->new_sym);
1737 for (cl = mapping->charlens; cl; cl = nextcl)
1740 gfc_free_expr (cl->length);
1746 /* Return a copy of gfc_charlen CL. Add the returned structure to
1747 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1749 static gfc_charlen *
1750 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1753 gfc_charlen *new_charlen;
1755 new_charlen = gfc_get_charlen ();
1756 new_charlen->next = mapping->charlens;
1757 new_charlen->length = gfc_copy_expr (cl->length);
1759 mapping->charlens = new_charlen;
1764 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1765 array variable that can be used as the actual argument for dummy
1766 argument SYM. Add any initialization code to BLOCK. PACKED is as
1767 for gfc_get_nodesc_array_type and DATA points to the first element
1768 in the passed array. */
1771 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1772 gfc_packed packed, tree data)
1777 type = gfc_typenode_for_spec (&sym->ts);
1778 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1779 !sym->attr.target && !sym->attr.pointer
1780 && !sym->attr.proc_pointer);
1782 var = gfc_create_var (type, "ifm");
1783 gfc_add_modify (block, var, fold_convert (type, data));
1789 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1790 and offset of descriptorless array type TYPE given that it has the same
1791 size as DESC. Add any set-up code to BLOCK. */
1794 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1801 offset = gfc_index_zero_node;
1802 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1804 dim = gfc_rank_cst[n];
1805 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1806 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1808 GFC_TYPE_ARRAY_LBOUND (type, n)
1809 = gfc_conv_descriptor_lbound_get (desc, dim);
1810 GFC_TYPE_ARRAY_UBOUND (type, n)
1811 = gfc_conv_descriptor_ubound_get (desc, dim);
1813 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1815 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1816 gfc_conv_descriptor_ubound_get (desc, dim),
1817 gfc_conv_descriptor_lbound_get (desc, dim));
1818 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1819 GFC_TYPE_ARRAY_LBOUND (type, n),
1821 tmp = gfc_evaluate_now (tmp, block);
1822 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1824 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1825 GFC_TYPE_ARRAY_LBOUND (type, n),
1826 GFC_TYPE_ARRAY_STRIDE (type, n));
1827 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1829 offset = gfc_evaluate_now (offset, block);
1830 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1834 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1835 in SE. The caller may still use se->expr and se->string_length after
1836 calling this function. */
1839 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1840 gfc_symbol * sym, gfc_se * se,
1843 gfc_interface_sym_mapping *sm;
1847 gfc_symbol *new_sym;
1849 gfc_symtree *new_symtree;
1851 /* Create a new symbol to represent the actual argument. */
1852 new_sym = gfc_new_symbol (sym->name, NULL);
1853 new_sym->ts = sym->ts;
1854 new_sym->as = gfc_copy_array_spec (sym->as);
1855 new_sym->attr.referenced = 1;
1856 new_sym->attr.dimension = sym->attr.dimension;
1857 new_sym->attr.codimension = sym->attr.codimension;
1858 new_sym->attr.pointer = sym->attr.pointer;
1859 new_sym->attr.allocatable = sym->attr.allocatable;
1860 new_sym->attr.flavor = sym->attr.flavor;
1861 new_sym->attr.function = sym->attr.function;
1863 /* Ensure that the interface is available and that
1864 descriptors are passed for array actual arguments. */
1865 if (sym->attr.flavor == FL_PROCEDURE)
1867 new_sym->formal = expr->symtree->n.sym->formal;
1868 new_sym->attr.always_explicit
1869 = expr->symtree->n.sym->attr.always_explicit;
1872 /* Create a fake symtree for it. */
1874 new_symtree = gfc_new_symtree (&root, sym->name);
1875 new_symtree->n.sym = new_sym;
1876 gcc_assert (new_symtree == root);
1878 /* Create a dummy->actual mapping. */
1879 sm = XCNEW (gfc_interface_sym_mapping);
1880 sm->next = mapping->syms;
1882 sm->new_sym = new_symtree;
1883 sm->expr = gfc_copy_expr (expr);
1886 /* Stabilize the argument's value. */
1887 if (!sym->attr.function && se)
1888 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1890 if (sym->ts.type == BT_CHARACTER)
1892 /* Create a copy of the dummy argument's length. */
1893 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1894 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1896 /* If the length is specified as "*", record the length that
1897 the caller is passing. We should use the callee's length
1898 in all other cases. */
1899 if (!new_sym->ts.u.cl->length && se)
1901 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1902 new_sym->ts.u.cl->backend_decl = se->string_length;
1909 /* Use the passed value as-is if the argument is a function. */
1910 if (sym->attr.flavor == FL_PROCEDURE)
1913 /* If the argument is either a string or a pointer to a string,
1914 convert it to a boundless character type. */
1915 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1917 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1918 tmp = build_pointer_type (tmp);
1919 if (sym->attr.pointer)
1920 value = build_fold_indirect_ref_loc (input_location,
1924 value = fold_convert (tmp, value);
1927 /* If the argument is a scalar, a pointer to an array or an allocatable,
1929 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1930 value = build_fold_indirect_ref_loc (input_location,
1933 /* For character(*), use the actual argument's descriptor. */
1934 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1935 value = build_fold_indirect_ref_loc (input_location,
1938 /* If the argument is an array descriptor, use it to determine
1939 information about the actual argument's shape. */
1940 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1941 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1943 /* Get the actual argument's descriptor. */
1944 desc = build_fold_indirect_ref_loc (input_location,
1947 /* Create the replacement variable. */
1948 tmp = gfc_conv_descriptor_data_get (desc);
1949 value = gfc_get_interface_mapping_array (&se->pre, sym,
1952 /* Use DESC to work out the upper bounds, strides and offset. */
1953 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1956 /* Otherwise we have a packed array. */
1957 value = gfc_get_interface_mapping_array (&se->pre, sym,
1958 PACKED_FULL, se->expr);
1960 new_sym->backend_decl = value;
1964 /* Called once all dummy argument mappings have been added to MAPPING,
1965 but before the mapping is used to evaluate expressions. Pre-evaluate
1966 the length of each argument, adding any initialization code to PRE and
1967 any finalization code to POST. */
1970 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1971 stmtblock_t * pre, stmtblock_t * post)
1973 gfc_interface_sym_mapping *sym;
1977 for (sym = mapping->syms; sym; sym = sym->next)
1978 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1979 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1981 expr = sym->new_sym->n.sym->ts.u.cl->length;
1982 gfc_apply_interface_mapping_to_expr (mapping, expr);
1983 gfc_init_se (&se, NULL);
1984 gfc_conv_expr (&se, expr);
1985 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1986 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1987 gfc_add_block_to_block (pre, &se.pre);
1988 gfc_add_block_to_block (post, &se.post);
1990 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1995 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1999 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2000 gfc_constructor_base base)
2003 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2005 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2008 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2009 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2010 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2016 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2020 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2025 for (; ref; ref = ref->next)
2029 for (n = 0; n < ref->u.ar.dimen; n++)
2031 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2032 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2033 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2035 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2042 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2043 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2049 /* Convert intrinsic function calls into result expressions. */
2052 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2060 arg1 = expr->value.function.actual->expr;
2061 if (expr->value.function.actual->next)
2062 arg2 = expr->value.function.actual->next->expr;
2066 sym = arg1->symtree->n.sym;
2068 if (sym->attr.dummy)
2073 switch (expr->value.function.isym->id)
2076 /* TODO figure out why this condition is necessary. */
2077 if (sym->attr.function
2078 && (arg1->ts.u.cl->length == NULL
2079 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2080 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2083 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2087 if (!sym->as || sym->as->rank == 0)
2090 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2092 dup = mpz_get_si (arg2->value.integer);
2097 dup = sym->as->rank;
2101 for (; d < dup; d++)
2105 if (!sym->as->upper[d] || !sym->as->lower[d])
2107 gfc_free_expr (new_expr);
2111 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2112 gfc_get_int_expr (gfc_default_integer_kind,
2114 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2116 new_expr = gfc_multiply (new_expr, tmp);
2122 case GFC_ISYM_LBOUND:
2123 case GFC_ISYM_UBOUND:
2124 /* TODO These implementations of lbound and ubound do not limit if
2125 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2127 if (!sym->as || sym->as->rank == 0)
2130 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2131 d = mpz_get_si (arg2->value.integer) - 1;
2133 /* TODO: If the need arises, this could produce an array of
2137 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2139 if (sym->as->lower[d])
2140 new_expr = gfc_copy_expr (sym->as->lower[d]);
2144 if (sym->as->upper[d])
2145 new_expr = gfc_copy_expr (sym->as->upper[d]);
2153 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2157 gfc_replace_expr (expr, new_expr);
2163 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2164 gfc_interface_mapping * mapping)
2166 gfc_formal_arglist *f;
2167 gfc_actual_arglist *actual;
2169 actual = expr->value.function.actual;
2170 f = map_expr->symtree->n.sym->formal;
2172 for (; f && actual; f = f->next, actual = actual->next)
2177 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2180 if (map_expr->symtree->n.sym->attr.dimension)
2185 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2187 for (d = 0; d < as->rank; d++)
2189 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2190 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2193 expr->value.function.esym->as = as;
2196 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2198 expr->value.function.esym->ts.u.cl->length
2199 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2201 gfc_apply_interface_mapping_to_expr (mapping,
2202 expr->value.function.esym->ts.u.cl->length);
2207 /* EXPR is a copy of an expression that appeared in the interface
2208 associated with MAPPING. Walk it recursively looking for references to
2209 dummy arguments that MAPPING maps to actual arguments. Replace each such
2210 reference with a reference to the associated actual argument. */
2213 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2216 gfc_interface_sym_mapping *sym;
2217 gfc_actual_arglist *actual;
2222 /* Copying an expression does not copy its length, so do that here. */
2223 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2225 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2226 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2229 /* Apply the mapping to any references. */
2230 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2232 /* ...and to the expression's symbol, if it has one. */
2233 /* TODO Find out why the condition on expr->symtree had to be moved into
2234 the loop rather than being outside it, as originally. */
2235 for (sym = mapping->syms; sym; sym = sym->next)
2236 if (expr->symtree && sym->old == expr->symtree->n.sym)
2238 if (sym->new_sym->n.sym->backend_decl)
2239 expr->symtree = sym->new_sym;
2241 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2244 /* ...and to subexpressions in expr->value. */
2245 switch (expr->expr_type)
2250 case EXPR_SUBSTRING:
2254 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2255 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2259 for (actual = expr->value.function.actual; actual; actual = actual->next)
2260 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2262 if (expr->value.function.esym == NULL
2263 && expr->value.function.isym != NULL
2264 && expr->value.function.actual->expr->symtree
2265 && gfc_map_intrinsic_function (expr, mapping))
2268 for (sym = mapping->syms; sym; sym = sym->next)
2269 if (sym->old == expr->value.function.esym)
2271 expr->value.function.esym = sym->new_sym->n.sym;
2272 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2273 expr->value.function.esym->result = sym->new_sym->n.sym;
2278 case EXPR_STRUCTURE:
2279 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2292 /* Evaluate interface expression EXPR using MAPPING. Store the result
2296 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2297 gfc_se * se, gfc_expr * expr)
2299 expr = gfc_copy_expr (expr);
2300 gfc_apply_interface_mapping_to_expr (mapping, expr);
2301 gfc_conv_expr (se, expr);
2302 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2303 gfc_free_expr (expr);
2307 /* Returns a reference to a temporary array into which a component of
2308 an actual argument derived type array is copied and then returned
2309 after the function call. */
2311 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2312 sym_intent intent, bool formal_ptr)
2330 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2332 gfc_init_se (&lse, NULL);
2333 gfc_init_se (&rse, NULL);
2335 /* Walk the argument expression. */
2336 rss = gfc_walk_expr (expr);
2338 gcc_assert (rss != gfc_ss_terminator);
2340 /* Initialize the scalarizer. */
2341 gfc_init_loopinfo (&loop);
2342 gfc_add_ss_to_loop (&loop, rss);
2344 /* Calculate the bounds of the scalarization. */
2345 gfc_conv_ss_startstride (&loop);
2347 /* Build an ss for the temporary. */
2348 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2349 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2351 base_type = gfc_typenode_for_spec (&expr->ts);
2352 if (GFC_ARRAY_TYPE_P (base_type)
2353 || GFC_DESCRIPTOR_TYPE_P (base_type))
2354 base_type = gfc_get_element_type (base_type);
2356 loop.temp_ss = gfc_get_ss ();;
2357 loop.temp_ss->type = GFC_SS_TEMP;
2358 loop.temp_ss->data.temp.type = base_type;
2360 if (expr->ts.type == BT_CHARACTER)
2361 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2363 loop.temp_ss->string_length = NULL;
2365 parmse->string_length = loop.temp_ss->string_length;
2366 loop.temp_ss->data.temp.dimen = loop.dimen;
2367 loop.temp_ss->next = gfc_ss_terminator;
2369 /* Associate the SS with the loop. */
2370 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2372 /* Setup the scalarizing loops. */
2373 gfc_conv_loop_setup (&loop, &expr->where);
2375 /* Pass the temporary descriptor back to the caller. */
2376 info = &loop.temp_ss->data.info;
2377 parmse->expr = info->descriptor;
2379 /* Setup the gfc_se structures. */
2380 gfc_copy_loopinfo_to_se (&lse, &loop);
2381 gfc_copy_loopinfo_to_se (&rse, &loop);
2384 lse.ss = loop.temp_ss;
2385 gfc_mark_ss_chain_used (rss, 1);
2386 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2388 /* Start the scalarized loop body. */
2389 gfc_start_scalarized_body (&loop, &body);
2391 /* Translate the expression. */
2392 gfc_conv_expr (&rse, expr);
2394 gfc_conv_tmp_array_ref (&lse);
2395 gfc_advance_se_ss_chain (&lse);
2397 if (intent != INTENT_OUT)
2399 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2400 gfc_add_expr_to_block (&body, tmp);
2401 gcc_assert (rse.ss == gfc_ss_terminator);
2402 gfc_trans_scalarizing_loops (&loop, &body);
2406 /* Make sure that the temporary declaration survives by merging
2407 all the loop declarations into the current context. */
2408 for (n = 0; n < loop.dimen; n++)
2410 gfc_merge_block_scope (&body);
2411 body = loop.code[loop.order[n]];
2413 gfc_merge_block_scope (&body);
2416 /* Add the post block after the second loop, so that any
2417 freeing of allocated memory is done at the right time. */
2418 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2420 /**********Copy the temporary back again.*********/
2422 gfc_init_se (&lse, NULL);
2423 gfc_init_se (&rse, NULL);
2425 /* Walk the argument expression. */
2426 lss = gfc_walk_expr (expr);
2427 rse.ss = loop.temp_ss;
2430 /* Initialize the scalarizer. */
2431 gfc_init_loopinfo (&loop2);
2432 gfc_add_ss_to_loop (&loop2, lss);
2434 /* Calculate the bounds of the scalarization. */
2435 gfc_conv_ss_startstride (&loop2);
2437 /* Setup the scalarizing loops. */
2438 gfc_conv_loop_setup (&loop2, &expr->where);
2440 gfc_copy_loopinfo_to_se (&lse, &loop2);
2441 gfc_copy_loopinfo_to_se (&rse, &loop2);
2443 gfc_mark_ss_chain_used (lss, 1);
2444 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2446 /* Declare the variable to hold the temporary offset and start the
2447 scalarized loop body. */
2448 offset = gfc_create_var (gfc_array_index_type, NULL);
2449 gfc_start_scalarized_body (&loop2, &body);
2451 /* Build the offsets for the temporary from the loop variables. The
2452 temporary array has lbounds of zero and strides of one in all
2453 dimensions, so this is very simple. The offset is only computed
2454 outside the innermost loop, so the overall transfer could be
2455 optimized further. */
2456 info = &rse.ss->data.info;
2457 dimen = info->dimen;
2459 tmp_index = gfc_index_zero_node;
2460 for (n = dimen - 1; n > 0; n--)
2463 tmp = rse.loop->loopvar[n];
2464 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2465 tmp, rse.loop->from[n]);
2466 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2469 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2470 rse.loop->to[n-1], rse.loop->from[n-1]);
2471 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2472 tmp_str, gfc_index_one_node);
2474 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2478 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2479 tmp_index, rse.loop->from[0]);
2480 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2482 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2483 rse.loop->loopvar[0], offset);
2485 /* Now use the offset for the reference. */
2486 tmp = build_fold_indirect_ref_loc (input_location,
2488 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2490 if (expr->ts.type == BT_CHARACTER)
2491 rse.string_length = expr->ts.u.cl->backend_decl;
2493 gfc_conv_expr (&lse, expr);
2495 gcc_assert (lse.ss == gfc_ss_terminator);
2497 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2498 gfc_add_expr_to_block (&body, tmp);
2500 /* Generate the copying loops. */
2501 gfc_trans_scalarizing_loops (&loop2, &body);
2503 /* Wrap the whole thing up by adding the second loop to the post-block
2504 and following it by the post-block of the first loop. In this way,
2505 if the temporary needs freeing, it is done after use! */
2506 if (intent != INTENT_IN)
2508 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2509 gfc_add_block_to_block (&parmse->post, &loop2.post);
2512 gfc_add_block_to_block (&parmse->post, &loop.post);
2514 gfc_cleanup_loop (&loop);
2515 gfc_cleanup_loop (&loop2);
2517 /* Pass the string length to the argument expression. */
2518 if (expr->ts.type == BT_CHARACTER)
2519 parmse->string_length = expr->ts.u.cl->backend_decl;
2521 /* Determine the offset for pointer formal arguments and set the
2525 size = gfc_index_one_node;
2526 offset = gfc_index_zero_node;
2527 for (n = 0; n < dimen; n++)
2529 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2531 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2532 tmp, gfc_index_one_node);
2533 gfc_conv_descriptor_ubound_set (&parmse->pre,
2537 gfc_conv_descriptor_lbound_set (&parmse->pre,
2540 gfc_index_one_node);
2541 size = gfc_evaluate_now (size, &parmse->pre);
2542 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2544 offset = gfc_evaluate_now (offset, &parmse->pre);
2545 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2546 rse.loop->to[n], rse.loop->from[n]);
2547 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2548 tmp, gfc_index_one_node);
2549 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2553 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2557 /* We want either the address for the data or the address of the descriptor,
2558 depending on the mode of passing array arguments. */
2560 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2562 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2568 /* Generate the code for argument list functions. */
2571 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2573 /* Pass by value for g77 %VAL(arg), pass the address
2574 indirectly for %LOC, else by reference. Thus %REF
2575 is a "do-nothing" and %LOC is the same as an F95
2577 if (strncmp (name, "%VAL", 4) == 0)
2578 gfc_conv_expr (se, expr);
2579 else if (strncmp (name, "%LOC", 4) == 0)
2581 gfc_conv_expr_reference (se, expr);
2582 se->expr = gfc_build_addr_expr (NULL, se->expr);
2584 else if (strncmp (name, "%REF", 4) == 0)
2585 gfc_conv_expr_reference (se, expr);
2587 gfc_error ("Unknown argument list function at %L", &expr->where);
2591 /* Takes a derived type expression and returns the address of a temporary
2592 class object of the 'declared' type. */
2594 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2595 gfc_typespec class_ts)
2599 gfc_symbol *declared = class_ts.u.derived;
2605 /* The derived type needs to be converted to a temporary
2607 tmp = gfc_typenode_for_spec (&class_ts);
2608 var = gfc_create_var (tmp, "class");
2611 cmp = gfc_find_component (declared, "$vptr", true, true);
2612 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2613 var, cmp->backend_decl, NULL_TREE);
2615 /* Remember the vtab corresponds to the derived type
2616 not to the class declared type. */
2617 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2619 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2620 gfc_add_modify (&parmse->pre, ctree,
2621 fold_convert (TREE_TYPE (ctree), tmp));
2623 /* Now set the data field. */
2624 cmp = gfc_find_component (declared, "$data", true, true);
2625 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2626 var, cmp->backend_decl, NULL_TREE);
2627 ss = gfc_walk_expr (e);
2628 if (ss == gfc_ss_terminator)
2630 gfc_conv_expr_reference (parmse, e);
2631 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2632 gfc_add_modify (&parmse->pre, ctree, tmp);
2636 gfc_conv_expr (parmse, e);
2637 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2640 /* Pass the address of the class object. */
2641 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2645 /* The following routine generates code for the intrinsic
2646 procedures from the ISO_C_BINDING module:
2648 * C_FUNLOC (function)
2649 * C_F_POINTER (subroutine)
2650 * C_F_PROCPOINTER (subroutine)
2651 * C_ASSOCIATED (function)
2652 One exception which is not handled here is C_F_POINTER with non-scalar
2653 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2656 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2657 gfc_actual_arglist * arg)
2662 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2664 if (arg->expr->rank == 0)
2665 gfc_conv_expr_reference (se, arg->expr);
2669 /* This is really the actual arg because no formal arglist is
2670 created for C_LOC. */
2671 fsym = arg->expr->symtree->n.sym;
2673 /* We should want it to do g77 calling convention. */
2675 && !(fsym->attr.pointer || fsym->attr.allocatable)
2676 && fsym->as->type != AS_ASSUMED_SHAPE;
2677 f = f || !sym->attr.always_explicit;
2679 argss = gfc_walk_expr (arg->expr);
2680 gfc_conv_array_parameter (se, arg->expr, argss, f,
2684 /* TODO -- the following two lines shouldn't be necessary, but if
2685 they're removed, a bug is exposed later in the code path.
2686 This workaround was thus introduced, but will have to be
2687 removed; please see PR 35150 for details about the issue. */
2688 se->expr = convert (pvoid_type_node, se->expr);
2689 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2693 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2695 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2696 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2697 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2698 gfc_conv_expr_reference (se, arg->expr);
2702 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2703 && arg->next->expr->rank == 0)
2704 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2706 /* Convert c_f_pointer if fptr is a scalar
2707 and convert c_f_procpointer. */
2711 gfc_init_se (&cptrse, NULL);
2712 gfc_conv_expr (&cptrse, arg->expr);
2713 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2714 gfc_add_block_to_block (&se->post, &cptrse.post);
2716 gfc_init_se (&fptrse, NULL);
2717 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2718 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2719 fptrse.want_pointer = 1;
2721 gfc_conv_expr (&fptrse, arg->next->expr);
2722 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2723 gfc_add_block_to_block (&se->post, &fptrse.post);
2725 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2726 && arg->next->expr->symtree->n.sym->attr.dummy)
2727 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2730 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2732 fold_convert (TREE_TYPE (fptrse.expr),
2737 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2742 /* Build the addr_expr for the first argument. The argument is
2743 already an *address* so we don't need to set want_pointer in
2745 gfc_init_se (&arg1se, NULL);
2746 gfc_conv_expr (&arg1se, arg->expr);
2747 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2748 gfc_add_block_to_block (&se->post, &arg1se.post);
2750 /* See if we were given two arguments. */
2751 if (arg->next == NULL)
2752 /* Only given one arg so generate a null and do a
2753 not-equal comparison against the first arg. */
2754 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2755 fold_convert (TREE_TYPE (arg1se.expr),
2756 null_pointer_node));
2762 /* Given two arguments so build the arg2se from second arg. */
2763 gfc_init_se (&arg2se, NULL);
2764 gfc_conv_expr (&arg2se, arg->next->expr);
2765 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2766 gfc_add_block_to_block (&se->post, &arg2se.post);
2768 /* Generate test to compare that the two args are equal. */
2769 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2770 arg1se.expr, arg2se.expr);
2771 /* Generate test to ensure that the first arg is not null. */
2772 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2773 arg1se.expr, null_pointer_node);
2775 /* Finally, the generated test must check that both arg1 is not
2776 NULL and that it is equal to the second arg. */
2777 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2778 not_null_expr, eq_expr);
2784 /* Nothing was done. */
2789 /* Generate code for a procedure call. Note can return se->post != NULL.
2790 If se->direct_byref is set then se->expr contains the return parameter.
2791 Return nonzero, if the call has alternate specifiers.
2792 'expr' is only needed for procedure pointer components. */
2795 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2796 gfc_actual_arglist * arg, gfc_expr * expr,
2799 gfc_interface_mapping mapping;
2814 gfc_formal_arglist *formal;
2815 int has_alternate_specifier = 0;
2816 bool need_interface_mapping;
2823 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2824 gfc_component *comp = NULL;
2826 arglist = NULL_TREE;
2827 retargs = NULL_TREE;
2828 stringargs = NULL_TREE;
2833 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2834 && conv_isocbinding_procedure (se, sym, arg))
2837 gfc_is_proc_ptr_comp (expr, &comp);
2841 if (!sym->attr.elemental)
2843 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2844 if (se->ss->useflags)
2846 gcc_assert ((!comp && gfc_return_by_reference (sym)
2847 && sym->result->attr.dimension)
2848 || (comp && comp->attr.dimension));
2849 gcc_assert (se->loop != NULL);
2851 /* Access the previously obtained result. */
2852 gfc_conv_tmp_array_ref (se);
2853 gfc_advance_se_ss_chain (se);
2857 info = &se->ss->data.info;
2862 gfc_init_block (&post);
2863 gfc_init_interface_mapping (&mapping);
2866 formal = sym->formal;
2867 need_interface_mapping = sym->attr.dimension ||
2868 (sym->ts.type == BT_CHARACTER
2869 && sym->ts.u.cl->length
2870 && sym->ts.u.cl->length->expr_type
2875 formal = comp->formal;
2876 need_interface_mapping = comp->attr.dimension ||
2877 (comp->ts.type == BT_CHARACTER
2878 && comp->ts.u.cl->length
2879 && comp->ts.u.cl->length->expr_type
2883 /* Evaluate the arguments. */
2884 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2887 fsym = formal ? formal->sym : NULL;
2888 parm_kind = MISSING;
2892 if (se->ignore_optional)
2894 /* Some intrinsics have already been resolved to the correct
2898 else if (arg->label)
2900 has_alternate_specifier = 1;
2905 /* Pass a NULL pointer for an absent arg. */
2906 gfc_init_se (&parmse, NULL);
2907 parmse.expr = null_pointer_node;
2908 if (arg->missing_arg_type == BT_CHARACTER)
2909 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2912 else if (fsym && fsym->ts.type == BT_CLASS
2913 && e->ts.type == BT_DERIVED)
2915 /* The derived type needs to be converted to a temporary
2917 gfc_init_se (&parmse, se);
2918 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2920 else if (se->ss && se->ss->useflags)
2922 /* An elemental function inside a scalarized loop. */
2923 gfc_init_se (&parmse, se);
2924 gfc_conv_expr_reference (&parmse, e);
2925 parm_kind = ELEMENTAL;
2929 /* A scalar or transformational function. */
2930 gfc_init_se (&parmse, NULL);
2931 argss = gfc_walk_expr (e);
2933 if (argss == gfc_ss_terminator)
2935 if (e->expr_type == EXPR_VARIABLE
2936 && e->symtree->n.sym->attr.cray_pointee
2937 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2939 /* The Cray pointer needs to be converted to a pointer to
2940 a type given by the expression. */
2941 gfc_conv_expr (&parmse, e);
2942 type = build_pointer_type (TREE_TYPE (parmse.expr));
2943 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2944 parmse.expr = convert (type, tmp);
2946 else if (fsym && fsym->attr.value)
2948 if (fsym->ts.type == BT_CHARACTER
2949 && fsym->ts.is_c_interop
2950 && fsym->ns->proc_name != NULL
2951 && fsym->ns->proc_name->attr.is_bind_c)
2954 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2955 if (parmse.expr == NULL)
2956 gfc_conv_expr (&parmse, e);
2959 gfc_conv_expr (&parmse, e);
2961 else if (arg->name && arg->name[0] == '%')
2962 /* Argument list functions %VAL, %LOC and %REF are signalled
2963 through arg->name. */
2964 conv_arglist_function (&parmse, arg->expr, arg->name);
2965 else if ((e->expr_type == EXPR_FUNCTION)
2966 && ((e->value.function.esym
2967 && e->value.function.esym->result->attr.pointer)
2968 || (!e->value.function.esym
2969 && e->symtree->n.sym->attr.pointer))
2970 && fsym && fsym->attr.target)
2972 gfc_conv_expr (&parmse, e);
2973 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2975 else if (e->expr_type == EXPR_FUNCTION
2976 && e->symtree->n.sym->result
2977 && e->symtree->n.sym->result != e->symtree->n.sym
2978 && e->symtree->n.sym->result->attr.proc_pointer)
2980 /* Functions returning procedure pointers. */
2981 gfc_conv_expr (&parmse, e);
2982 if (fsym && fsym->attr.proc_pointer)
2983 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2987 gfc_conv_expr_reference (&parmse, e);
2989 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2990 allocated on entry, it must be deallocated. */
2991 if (fsym && fsym->attr.allocatable
2992 && fsym->attr.intent == INTENT_OUT)
2996 gfc_init_block (&block);
2997 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2999 gfc_add_expr_to_block (&block, tmp);
3000 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3001 parmse.expr, null_pointer_node);
3002 gfc_add_expr_to_block (&block, tmp);
3004 if (fsym->attr.optional
3005 && e->expr_type == EXPR_VARIABLE
3006 && e->symtree->n.sym->attr.optional)
3008 tmp = fold_build3 (COND_EXPR, void_type_node,
3009 gfc_conv_expr_present (e->symtree->n.sym),
3010 gfc_finish_block (&block),
3011 build_empty_stmt (input_location));
3014 tmp = gfc_finish_block (&block);
3016 gfc_add_expr_to_block (&se->pre, tmp);
3019 if (fsym && e->expr_type != EXPR_NULL
3020 && ((fsym->attr.pointer
3021 && fsym->attr.flavor != FL_PROCEDURE)
3022 || (fsym->attr.proc_pointer
3023 && !(e->expr_type == EXPR_VARIABLE
3024 && e->symtree->n.sym->attr.dummy))
3025 || (e->expr_type == EXPR_VARIABLE
3026 && gfc_is_proc_ptr_comp (e, NULL))
3027 || fsym->attr.allocatable))
3029 /* Scalar pointer dummy args require an extra level of
3030 indirection. The null pointer already contains
3031 this level of indirection. */
3032 parm_kind = SCALAR_POINTER;
3033 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3039 /* If the procedure requires an explicit interface, the actual
3040 argument is passed according to the corresponding formal
3041 argument. If the corresponding formal argument is a POINTER,
3042 ALLOCATABLE or assumed shape, we do not use g77's calling
3043 convention, and pass the address of the array descriptor
3044 instead. Otherwise we use g77's calling convention. */
3047 && !(fsym->attr.pointer || fsym->attr.allocatable)
3048 && fsym->as->type != AS_ASSUMED_SHAPE;
3050 f = f || !comp->attr.always_explicit;
3052 f = f || !sym->attr.always_explicit;
3054 if (e->expr_type == EXPR_VARIABLE
3055 && is_subref_array (e))
3056 /* The actual argument is a component reference to an
3057 array of derived types. In this case, the argument
3058 is converted to a temporary, which is passed and then
3059 written back after the procedure call. */
3060 gfc_conv_subref_array_arg (&parmse, e, f,
3061 fsym ? fsym->attr.intent : INTENT_INOUT,
3062 fsym && fsym->attr.pointer);
3064 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3067 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3068 allocated on entry, it must be deallocated. */
3069 if (fsym && fsym->attr.allocatable
3070 && fsym->attr.intent == INTENT_OUT)
3072 tmp = build_fold_indirect_ref_loc (input_location,
3074 tmp = gfc_trans_dealloc_allocated (tmp);
3075 if (fsym->attr.optional
3076 && e->expr_type == EXPR_VARIABLE
3077 && e->symtree->n.sym->attr.optional)
3078 tmp = fold_build3 (COND_EXPR, void_type_node,
3079 gfc_conv_expr_present (e->symtree->n.sym),
3080 tmp, build_empty_stmt (input_location));
3081 gfc_add_expr_to_block (&se->pre, tmp);
3086 /* The case with fsym->attr.optional is that of a user subroutine
3087 with an interface indicating an optional argument. When we call
3088 an intrinsic subroutine, however, fsym is NULL, but we might still
3089 have an optional argument, so we proceed to the substitution
3091 if (e && (fsym == NULL || fsym->attr.optional))
3093 /* If an optional argument is itself an optional dummy argument,
3094 check its presence and substitute a null if absent. This is
3095 only needed when passing an array to an elemental procedure
3096 as then array elements are accessed - or no NULL pointer is
3097 allowed and a "1" or "0" should be passed if not present.
3098 When passing a non-array-descriptor full array to a
3099 non-array-descriptor dummy, no check is needed. For
3100 array-descriptor actual to array-descriptor dummy, see
3101 PR 41911 for why a check has to be inserted.
3102 fsym == NULL is checked as intrinsics required the descriptor
3103 but do not always set fsym. */
3104 if (e->expr_type == EXPR_VARIABLE
3105 && e->symtree->n.sym->attr.optional
3106 && ((e->rank > 0 && sym->attr.elemental)
3107 || e->representation.length || e->ts.type == BT_CHARACTER
3109 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3110 || fsym->as->type == AS_DEFERRED))))
3111 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3112 e->representation.length);
3117 /* Obtain the character length of an assumed character length
3118 length procedure from the typespec. */
3119 if (fsym->ts.type == BT_CHARACTER
3120 && parmse.string_length == NULL_TREE
3121 && e->ts.type == BT_PROCEDURE
3122 && e->symtree->n.sym->ts.type == BT_CHARACTER
3123 && e->symtree->n.sym->ts.u.cl->length != NULL
3124 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3126 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3127 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3131 if (fsym && need_interface_mapping && e)
3132 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3134 gfc_add_block_to_block (&se->pre, &parmse.pre);
3135 gfc_add_block_to_block (&post, &parmse.post);
3137 /* Allocated allocatable components of derived types must be
3138 deallocated for non-variable scalars. Non-variable arrays are
3139 dealt with in trans-array.c(gfc_conv_array_parameter). */
3140 if (e && e->ts.type == BT_DERIVED
3141 && e->ts.u.derived->attr.alloc_comp
3142 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3143 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3146 tmp = build_fold_indirect_ref_loc (input_location,
3148 parm_rank = e->rank;
3156 case (SCALAR_POINTER):
3157 tmp = build_fold_indirect_ref_loc (input_location,
3162 if (e->expr_type == EXPR_OP
3163 && e->value.op.op == INTRINSIC_PARENTHESES
3164 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3167 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3168 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3169 gfc_add_expr_to_block (&se->post, local_tmp);
3172 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3174 gfc_add_expr_to_block (&se->post, tmp);
3177 /* Add argument checking of passing an unallocated/NULL actual to
3178 a nonallocatable/nonpointer dummy. */
3180 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3182 symbol_attribute *attr;
3186 if (e->expr_type == EXPR_VARIABLE)
3187 attr = &e->symtree->n.sym->attr;
3188 else if (e->expr_type == EXPR_FUNCTION)
3190 /* For intrinsic functions, the gfc_attr are not available. */
3191 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3192 goto end_pointer_check;
3194 if (e->symtree->n.sym->attr.generic)
3195 attr = &e->value.function.esym->attr;
3197 attr = &e->symtree->n.sym->result->attr;
3200 goto end_pointer_check;
3204 /* If the actual argument is an optional pointer/allocatable and
3205 the formal argument takes an nonpointer optional value,
3206 it is invalid to pass a non-present argument on, even
3207 though there is no technical reason for this in gfortran.
3208 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3209 tree present, nullptr, type;
3211 if (attr->allocatable
3212 && (fsym == NULL || !fsym->attr.allocatable))
3213 asprintf (&msg, "Allocatable actual argument '%s' is not "
3214 "allocated or not present", e->symtree->n.sym->name);
3215 else if (attr->pointer
3216 && (fsym == NULL || !fsym->attr.pointer))
3217 asprintf (&msg, "Pointer actual argument '%s' is not "
3218 "associated or not present",
3219 e->symtree->n.sym->name);
3220 else if (attr->proc_pointer
3221 && (fsym == NULL || !fsym->attr.proc_pointer))
3222 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3223 "associated or not present",
3224 e->symtree->n.sym->name);
3226 goto end_pointer_check;
3228 present = gfc_conv_expr_present (e->symtree->n.sym);
3229 type = TREE_TYPE (present);
3230 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3231 fold_convert (type, null_pointer_node));
3232 type = TREE_TYPE (parmse.expr);
3233 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3234 fold_convert (type, null_pointer_node));
3235 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3240 if (attr->allocatable
3241 && (fsym == NULL || !fsym->attr.allocatable))
3242 asprintf (&msg, "Allocatable actual argument '%s' is not "
3243 "allocated", e->symtree->n.sym->name);
3244 else if (attr->pointer
3245 && (fsym == NULL || !fsym->attr.pointer))
3246 asprintf (&msg, "Pointer actual argument '%s' is not "
3247 "associated", e->symtree->n.sym->name);
3248 else if (attr->proc_pointer
3249 && (fsym == NULL || !fsym->attr.proc_pointer))
3250 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3251 "associated", e->symtree->n.sym->name);
3253 goto end_pointer_check;
3256 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3257 fold_convert (TREE_TYPE (parmse.expr),
3258 null_pointer_node));
3261 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3268 /* Character strings are passed as two parameters, a length and a
3269 pointer - except for Bind(c) which only passes the pointer. */
3270 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3271 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
3273 arglist = gfc_chainon_list (arglist, parmse.expr);
3275 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3282 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3283 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3284 else if (ts.type == BT_CHARACTER)
3286 if (ts.u.cl->length == NULL)
3288 /* Assumed character length results are not allowed by 5.1.1.5 of the
3289 standard and are trapped in resolve.c; except in the case of SPREAD
3290 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3291 we take the character length of the first argument for the result.
3292 For dummies, we have to look through the formal argument list for
3293 this function and use the character length found there.*/
3294 if (!sym->attr.dummy)
3295 cl.backend_decl = TREE_VALUE (stringargs);
3298 formal = sym->ns->proc_name->formal;
3299 for (; formal; formal = formal->next)
3300 if (strcmp (formal->sym->name, sym->name) == 0)
3301 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3308 /* Calculate the length of the returned string. */
3309 gfc_init_se (&parmse, NULL);
3310 if (need_interface_mapping)
3311 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3313 gfc_conv_expr (&parmse, ts.u.cl->length);
3314 gfc_add_block_to_block (&se->pre, &parmse.pre);
3315 gfc_add_block_to_block (&se->post, &parmse.post);
3317 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3318 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3319 build_int_cst (gfc_charlen_type_node, 0));
3320 cl.backend_decl = tmp;
3323 /* Set up a charlen structure for it. */
3328 len = cl.backend_decl;
3331 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3332 || (!comp && gfc_return_by_reference (sym));
3335 if (se->direct_byref)
3337 /* Sometimes, too much indirection can be applied; e.g. for
3338 function_result = array_valued_recursive_function. */
3339 if (TREE_TYPE (TREE_TYPE (se->expr))
3340 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3341 && GFC_DESCRIPTOR_TYPE_P
3342 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3343 se->expr = build_fold_indirect_ref_loc (input_location,
3346 result = build_fold_indirect_ref_loc (input_location,
3348 retargs = gfc_chainon_list (retargs, se->expr);
3350 else if (comp && comp->attr.dimension)
3352 gcc_assert (se->loop && info);
3354 /* Set the type of the array. */
3355 tmp = gfc_typenode_for_spec (&comp->ts);
3356 info->dimen = se->loop->dimen;
3358 /* Evaluate the bounds of the result, if known. */
3359 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3361 /* Create a temporary to store the result. In case the function
3362 returns a pointer, the temporary will be a shallow copy and
3363 mustn't be deallocated. */
3364 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3365 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3366 NULL_TREE, false, !comp->attr.pointer,
3367 callee_alloc, &se->ss->expr->where);
3369 /* Pass the temporary as the first argument. */
3370 result = info->descriptor;
3371 tmp = gfc_build_addr_expr (NULL_TREE, result);
3372 retargs = gfc_chainon_list (retargs, tmp);
3374 else if (!comp && sym->result->attr.dimension)
3376 gcc_assert (se->loop && info);
3378 /* Set the type of the array. */
3379 tmp = gfc_typenode_for_spec (&ts);
3380 info->dimen = se->loop->dimen;
3382 /* Evaluate the bounds of the result, if known. */
3383 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3385 /* Create a temporary to store the result. In case the function
3386 returns a pointer, the temporary will be a shallow copy and
3387 mustn't be deallocated. */
3388 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3389 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3390 NULL_TREE, false, !sym->attr.pointer,
3391 callee_alloc, &se->ss->expr->where);
3393 /* Pass the temporary as the first argument. */
3394 result = info->descriptor;
3395 tmp = gfc_build_addr_expr (NULL_TREE, result);
3396 retargs = gfc_chainon_list (retargs, tmp);
3398 else if (ts.type == BT_CHARACTER)
3400 /* Pass the string length. */
3401 type = gfc_get_character_type (ts.kind, ts.u.cl);
3402 type = build_pointer_type (type);
3404 /* Return an address to a char[0:len-1]* temporary for
3405 character pointers. */
3406 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3407 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3409 var = gfc_create_var (type, "pstr");
3411 if ((!comp && sym->attr.allocatable)
3412 || (comp && comp->attr.allocatable))
3413 gfc_add_modify (&se->pre, var,
3414 fold_convert (TREE_TYPE (var),
3415 null_pointer_node));
3417 /* Provide an address expression for the function arguments. */
3418 var = gfc_build_addr_expr (NULL_TREE, var);
3421 var = gfc_conv_string_tmp (se, type, len);
3423 retargs = gfc_chainon_list (retargs, var);
3427 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3429 type = gfc_get_complex_type (ts.kind);
3430 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3431 retargs = gfc_chainon_list (retargs, var);
3434 /* Add the string length to the argument list. */
3435 if (ts.type == BT_CHARACTER)
3436 retargs = gfc_chainon_list (retargs, len);
3438 gfc_free_interface_mapping (&mapping);
3440 /* Add the return arguments. */
3441 arglist = chainon (retargs, arglist);
3443 /* Add the hidden string length parameters to the arguments. */
3444 arglist = chainon (arglist, stringargs);
3446 /* We may want to append extra arguments here. This is used e.g. for
3447 calls to libgfortran_matmul_??, which need extra information. */
3448 if (append_args != NULL_TREE)
3449 arglist = chainon (arglist, append_args);
3451 /* Generate the actual call. */
3452 conv_function_val (se, sym, expr);
3454 /* If there are alternate return labels, function type should be
3455 integer. Can't modify the type in place though, since it can be shared
3456 with other functions. For dummy arguments, the typing is done to
3457 to this result, even if it has to be repeated for each call. */
3458 if (has_alternate_specifier
3459 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3461 if (!sym->attr.dummy)
3463 TREE_TYPE (sym->backend_decl)
3464 = build_function_type (integer_type_node,
3465 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3466 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3469 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3472 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3473 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3475 /* If we have a pointer function, but we don't want a pointer, e.g.
3478 where f is pointer valued, we have to dereference the result. */
3479 if (!se->want_pointer && !byref
3480 && (sym->attr.pointer || sym->attr.allocatable)
3481 && !gfc_is_proc_ptr_comp (expr, NULL))
3482 se->expr = build_fold_indirect_ref_loc (input_location,
3485 /* f2c calling conventions require a scalar default real function to
3486 return a double precision result. Convert this back to default
3487 real. We only care about the cases that can happen in Fortran 77.
3489 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3490 && sym->ts.kind == gfc_default_real_kind
3491 && !sym->attr.always_explicit)
3492 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3494 /* A pure function may still have side-effects - it may modify its
3496 TREE_SIDE_EFFECTS (se->expr) = 1;
3498 if (!sym->attr.pure)
3499 TREE_SIDE_EFFECTS (se->expr) = 1;
3504 /* Add the function call to the pre chain. There is no expression. */
3505 gfc_add_expr_to_block (&se->pre, se->expr);
3506 se->expr = NULL_TREE;
3508 if (!se->direct_byref)
3510 if (sym->attr.dimension || (comp && comp->attr.dimension))
3512 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3514 /* Check the data pointer hasn't been modified. This would
3515 happen in a function returning a pointer. */
3516 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3517 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3519 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3522 se->expr = info->descriptor;
3523 /* Bundle in the string length. */
3524 se->string_length = len;
3526 else if (ts.type == BT_CHARACTER)
3528 /* Dereference for character pointer results. */
3529 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3530 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3531 se->expr = build_fold_indirect_ref_loc (input_location, var);
3535 se->string_length = len;
3539 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3540 se->expr = build_fold_indirect_ref_loc (input_location, var);
3545 /* Follow the function call with the argument post block. */
3548 gfc_add_block_to_block (&se->pre, &post);
3550 /* Transformational functions of derived types with allocatable
3551 components must have the result allocatable components copied. */
3552 arg = expr->value.function.actual;
3553 if (result && arg && expr->rank
3554 && expr->value.function.isym
3555 && expr->value.function.isym->transformational
3556 && arg->expr->ts.type == BT_DERIVED
3557 && arg->expr->ts.u.derived->attr.alloc_comp)
3560 /* Copy the allocatable components. We have to use a
3561 temporary here to prevent source allocatable components
3562 from being corrupted. */
3563 tmp2 = gfc_evaluate_now (result, &se->pre);
3564 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3565 result, tmp2, expr->rank);
3566 gfc_add_expr_to_block (&se->pre, tmp);
3567 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3569 gfc_add_expr_to_block (&se->pre, tmp);
3571 /* Finally free the temporary's data field. */
3572 tmp = gfc_conv_descriptor_data_get (tmp2);
3573 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3574 gfc_add_expr_to_block (&se->pre, tmp);
3578 gfc_add_block_to_block (&se->post, &post);
3580 return has_alternate_specifier;
3584 /* Fill a character string with spaces. */
3587 fill_with_spaces (tree start, tree type, tree size)
3589 stmtblock_t block, loop;
3590 tree i, el, exit_label, cond, tmp;
3592 /* For a simple char type, we can call memset(). */
3593 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3594 return build_call_expr_loc (input_location,
3595 built_in_decls[BUILT_IN_MEMSET], 3, start,
3596 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3597 lang_hooks.to_target_charset (' ')),
3600 /* Otherwise, we use a loop:
3601 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3605 /* Initialize variables. */
3606 gfc_init_block (&block);
3607 i = gfc_create_var (sizetype, "i");
3608 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3609 el = gfc_create_var (build_pointer_type (type), "el");
3610 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3611 exit_label = gfc_build_label_decl (NULL_TREE);
3612 TREE_USED (exit_label) = 1;
3616 gfc_init_block (&loop);
3618 /* Exit condition. */
3619 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3620 fold_convert (sizetype, integer_zero_node));
3621 tmp = build1_v (GOTO_EXPR, exit_label);
3622 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3623 build_empty_stmt (input_location));
3624 gfc_add_expr_to_block (&loop, tmp);
3627 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3628 build_int_cst (type,
3629 lang_hooks.to_target_charset (' ')));
3631 /* Increment loop variables. */
3632 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3633 TYPE_SIZE_UNIT (type)));
3634 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3636 TYPE_SIZE_UNIT (type)));
3638 /* Making the loop... actually loop! */
3639 tmp = gfc_finish_block (&loop);
3640 tmp = build1_v (LOOP_EXPR, tmp);
3641 gfc_add_expr_to_block (&block, tmp);
3643 /* The exit label. */
3644 tmp = build1_v (LABEL_EXPR, exit_label);
3645 gfc_add_expr_to_block (&block, tmp);
3648 return gfc_finish_block (&block);
3652 /* Generate code to copy a string. */
3655 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3656 int dkind, tree slength, tree src, int skind)
3658 tree tmp, dlen, slen;
3667 stmtblock_t tempblock;
3669 gcc_assert (dkind == skind);
3671 if (slength != NULL_TREE)
3673 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3674 ssc = string_to_single_character (slen, src, skind);
3678 slen = build_int_cst (size_type_node, 1);
3682 if (dlength != NULL_TREE)
3684 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3685 dsc = string_to_single_character (slen, dest, dkind);
3689 dlen = build_int_cst (size_type_node, 1);
3693 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3694 ssc = string_to_single_character (slen, src, skind);
3695 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3696 dsc = string_to_single_character (dlen, dest, dkind);
3699 /* Assign directly if the types are compatible. */
3700 if (dsc != NULL_TREE && ssc != NULL_TREE
3701 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3703 gfc_add_modify (block, dsc, ssc);
3707 /* Do nothing if the destination length is zero. */
3708 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3709 build_int_cst (size_type_node, 0));
3711 /* The following code was previously in _gfortran_copy_string:
3713 // The two strings may overlap so we use memmove.
3715 copy_string (GFC_INTEGER_4 destlen, char * dest,
3716 GFC_INTEGER_4 srclen, const char * src)
3718 if (srclen >= destlen)
3720 // This will truncate if too long.
3721 memmove (dest, src, destlen);
3725 memmove (dest, src, srclen);
3727 memset (&dest[srclen], ' ', destlen - srclen);
3731 We're now doing it here for better optimization, but the logic
3734 /* For non-default character kinds, we have to multiply the string
3735 length by the base type size. */
3736 chartype = gfc_get_char_type (dkind);
3737 slen = fold_build2 (MULT_EXPR, size_type_node,
3738 fold_convert (size_type_node, slen),
3739 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3740 dlen = fold_build2 (MULT_EXPR, size_type_node,
3741 fold_convert (size_type_node, dlen),
3742 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3745 dest = fold_convert (pvoid_type_node, dest);
3747 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3750 src = fold_convert (pvoid_type_node, src);
3752 src = gfc_build_addr_expr (pvoid_type_node, src);
3754 /* Truncate string if source is too long. */
3755 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3756 tmp2 = build_call_expr_loc (input_location,
3757 built_in_decls[BUILT_IN_MEMMOVE],
3758 3, dest, src, dlen);
3760 /* Else copy and pad with spaces. */
3761 tmp3 = build_call_expr_loc (input_location,
3762 built_in_decls[BUILT_IN_MEMMOVE],
3763 3, dest, src, slen);
3765 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3766 fold_convert (sizetype, slen));
3767 tmp4 = fill_with_spaces (tmp4, chartype,
3768 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3771 gfc_init_block (&tempblock);
3772 gfc_add_expr_to_block (&tempblock, tmp3);
3773 gfc_add_expr_to_block (&tempblock, tmp4);
3774 tmp3 = gfc_finish_block (&tempblock);
3776 /* The whole copy_string function is there. */
3777 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3778 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3779 build_empty_stmt (input_location));
3780 gfc_add_expr_to_block (block, tmp);
3784 /* Translate a statement function.
3785 The value of a statement function reference is obtained by evaluating the
3786 expression using the values of the actual arguments for the values of the
3787 corresponding dummy arguments. */
3790 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3794 gfc_formal_arglist *fargs;
3795 gfc_actual_arglist *args;
3798 gfc_saved_var *saved_vars;
3804 sym = expr->symtree->n.sym;
3805 args = expr->value.function.actual;
3806 gfc_init_se (&lse, NULL);
3807 gfc_init_se (&rse, NULL);
3810 for (fargs = sym->formal; fargs; fargs = fargs->next)
3812 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3813 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3815 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3817 /* Each dummy shall be specified, explicitly or implicitly, to be
3819 gcc_assert (fargs->sym->attr.dimension == 0);
3822 /* Create a temporary to hold the value. */
3823 type = gfc_typenode_for_spec (&fsym->ts);
3824 temp_vars[n] = gfc_create_var (type, fsym->name);
3826 if (fsym->ts.type == BT_CHARACTER)
3828 /* Copy string arguments. */
3831 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3832 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3834 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3835 tmp = gfc_build_addr_expr (build_pointer_type (type),
3838 gfc_conv_expr (&rse, args->expr);
3839 gfc_conv_string_parameter (&rse);
3840 gfc_add_block_to_block (&se->pre, &lse.pre);
3841 gfc_add_block_to_block (&se->pre, &rse.pre);
3843 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3844 rse.string_length, rse.expr, fsym->ts.kind);
3845 gfc_add_block_to_block (&se->pre, &lse.post);
3846 gfc_add_block_to_block (&se->pre, &rse.post);
3850 /* For everything else, just evaluate the expression. */
3851 gfc_conv_expr (&lse, args->expr);
3853 gfc_add_block_to_block (&se->pre, &lse.pre);
3854 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3855 gfc_add_block_to_block (&se->pre, &lse.post);
3861 /* Use the temporary variables in place of the real ones. */
3862 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3863 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3865 gfc_conv_expr (se, sym->value);
3867 if (sym->ts.type == BT_CHARACTER)
3869 gfc_conv_const_charlen (sym->ts.u.cl);
3871 /* Force the expression to the correct length. */
3872 if (!INTEGER_CST_P (se->string_length)
3873 || tree_int_cst_lt (se->string_length,
3874 sym->ts.u.cl->backend_decl))
3876 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3877 tmp = gfc_create_var (type, sym->name);
3878 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3879 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3880 sym->ts.kind, se->string_length, se->expr,
3884 se->string_length = sym->ts.u.cl->backend_decl;
3887 /* Restore the original variables. */
3888 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3889 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3890 gfc_free (saved_vars);
3894 /* Translate a function expression. */
3897 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3901 if (expr->value.function.isym)
3903 gfc_conv_intrinsic_function (se, expr);
3907 /* We distinguish statement functions from general functions to improve
3908 runtime performance. */
3909 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3911 gfc_conv_statement_function (se, expr);
3915 /* expr.value.function.esym is the resolved (specific) function symbol for
3916 most functions. However this isn't set for dummy procedures. */
3917 sym = expr->value.function.esym;
3919 sym = expr->symtree->n.sym;
3921 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3926 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3929 is_zero_initializer_p (gfc_expr * expr)
3931 if (expr->expr_type != EXPR_CONSTANT)
3934 /* We ignore constants with prescribed memory representations for now. */
3935 if (expr->representation.string)
3938 switch (expr->ts.type)
3941 return mpz_cmp_si (expr->value.integer, 0) == 0;
3944 return mpfr_zero_p (expr->value.real)
3945 && MPFR_SIGN (expr->value.real) >= 0;
3948 return expr->value.logical == 0;
3951 return mpfr_zero_p (mpc_realref (expr->value.complex))
3952 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3953 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3954 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3964 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3966 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3967 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3969 gfc_conv_tmp_array_ref (se);
3970 gfc_advance_se_ss_chain (se);
3974 /* Build a static initializer. EXPR is the expression for the initial value.
3975 The other parameters describe the variable of the component being
3976 initialized. EXPR may be null. */
3979 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3980 bool array, bool pointer)
3984 if (!(expr || pointer))
3987 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3988 (these are the only two iso_c_binding derived types that can be
3989 used as initialization expressions). If so, we need to modify
3990 the 'expr' to be that for a (void *). */
3991 if (expr != NULL && expr->ts.type == BT_DERIVED
3992 && expr->ts.is_iso_c && expr->ts.u.derived)
3994 gfc_symbol *derived = expr->ts.u.derived;
3996 /* The derived symbol has already been converted to a (void *). Use
3998 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3999 expr->ts.f90_type = derived->ts.f90_type;
4001 gfc_init_se (&se, NULL);
4002 gfc_conv_constant (&se, expr);
4008 /* Arrays need special handling. */
4010 return gfc_build_null_descriptor (type);
4011 /* Special case assigning an array to zero. */
4012 else if (is_zero_initializer_p (expr))
4013 return build_constructor (type, NULL);
4015 return gfc_conv_array_initializer (type, expr);
4018 return fold_convert (type, null_pointer_node);
4025 gfc_init_se (&se, NULL);
4026 gfc_conv_structure (&se, expr, 1);
4030 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4033 gfc_init_se (&se, NULL);
4034 gfc_conv_constant (&se, expr);
4041 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4053 gfc_start_block (&block);
4055 /* Initialize the scalarizer. */
4056 gfc_init_loopinfo (&loop);
4058 gfc_init_se (&lse, NULL);
4059 gfc_init_se (&rse, NULL);
4062 rss = gfc_walk_expr (expr);
4063 if (rss == gfc_ss_terminator)
4065 /* The rhs is scalar. Add a ss for the expression. */
4066 rss = gfc_get_ss ();
4067 rss->next = gfc_ss_terminator;
4068 rss->type = GFC_SS_SCALAR;
4072 /* Create a SS for the destination. */
4073 lss = gfc_get_ss ();
4074 lss->type = GFC_SS_COMPONENT;
4076 lss->shape = gfc_get_shape (cm->as->rank);
4077 lss->next = gfc_ss_terminator;
4078 lss->data.info.dimen = cm->as->rank;
4079 lss->data.info.descriptor = dest;
4080 lss->data.info.data = gfc_conv_array_data (dest);
4081 lss->data.info.offset = gfc_conv_array_offset (dest);
4082 for (n = 0; n < cm->as->rank; n++)
4084 lss->data.info.dim[n] = n;
4085 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4086 lss->data.info.stride[n] = gfc_index_one_node;
4088 mpz_init (lss->shape[n]);
4089 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4090 cm->as->lower[n]->value.integer);
4091 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4094 /* Associate the SS with the loop. */
4095 gfc_add_ss_to_loop (&loop, lss);
4096 gfc_add_ss_to_loop (&loop, rss);
4098 /* Calculate the bounds of the scalarization. */
4099 gfc_conv_ss_startstride (&loop);
4101 /* Setup the scalarizing loops. */
4102 gfc_conv_loop_setup (&loop, &expr->where);
4104 /* Setup the gfc_se structures. */
4105 gfc_copy_loopinfo_to_se (&lse, &loop);
4106 gfc_copy_loopinfo_to_se (&rse, &loop);
4109 gfc_mark_ss_chain_used (rss, 1);
4111 gfc_mark_ss_chain_used (lss, 1);
4113 /* Start the scalarized loop body. */
4114 gfc_start_scalarized_body (&loop, &body);
4116 gfc_conv_tmp_array_ref (&lse);
4117 if (cm->ts.type == BT_CHARACTER)
4118 lse.string_length = cm->ts.u.cl->backend_decl;
4120 gfc_conv_expr (&rse, expr);
4122 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4123 gfc_add_expr_to_block (&body, tmp);
4125 gcc_assert (rse.ss == gfc_ss_terminator);
4127 /* Generate the copying loops. */
4128 gfc_trans_scalarizing_loops (&loop, &body);
4130 /* Wrap the whole thing up. */
4131 gfc_add_block_to_block (&block, &loop.pre);
4132 gfc_add_block_to_block (&block, &loop.post);
4134 for (n = 0; n < cm->as->rank; n++)
4135 mpz_clear (lss->shape[n]);
4136 gfc_free (lss->shape);
4138 gfc_cleanup_loop (&loop);
4140 return gfc_finish_block (&block);
4145 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4156 gfc_expr *arg = NULL;
4158 gfc_start_block (&block);
4159 gfc_init_se (&se, NULL);
4161 /* Get the descriptor for the expressions. */
4162 rss = gfc_walk_expr (expr);
4163 se.want_pointer = 0;
4164 gfc_conv_expr_descriptor (&se, expr, rss);
4165 gfc_add_block_to_block (&block, &se.pre);
4166 gfc_add_modify (&block, dest, se.expr);
4168 /* Deal with arrays of derived types with allocatable components. */
4169 if (cm->ts.type == BT_DERIVED
4170 && cm->ts.u.derived->attr.alloc_comp)
4171 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4175 tmp = gfc_duplicate_allocatable (dest, se.expr,
4176 TREE_TYPE(cm->backend_decl),
4179 gfc_add_expr_to_block (&block, tmp);
4180 gfc_add_block_to_block (&block, &se.post);
4182 if (expr->expr_type != EXPR_VARIABLE)
4183 gfc_conv_descriptor_data_set (&block, se.expr,
4186 /* We need to know if the argument of a conversion function is a
4187 variable, so that the correct lower bound can be used. */
4188 if (expr->expr_type == EXPR_FUNCTION
4189 && expr->value.function.isym
4190 && expr->value.function.isym->conversion
4191 && expr->value.function.actual->expr
4192 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4193 arg = expr->value.function.actual->expr;
4195 /* Obtain the array spec of full array references. */
4197 as = gfc_get_full_arrayspec_from_expr (arg);
4199 as = gfc_get_full_arrayspec_from_expr (expr);
4201 /* Shift the lbound and ubound of temporaries to being unity,
4202 rather than zero, based. Always calculate the offset. */
4203 offset = gfc_conv_descriptor_offset_get (dest);
4204 gfc_add_modify (&block, offset, gfc_index_zero_node);
4205 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4207 for (n = 0; n < expr->rank; n++)
4212 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4213 TODO It looks as if gfc_conv_expr_descriptor should return
4214 the correct bounds and that the following should not be
4215 necessary. This would simplify gfc_conv_intrinsic_bound
4217 if (as && as->lower[n])
4220 gfc_init_se (&lbse, NULL);
4221 gfc_conv_expr (&lbse, as->lower[n]);
4222 gfc_add_block_to_block (&block, &lbse.pre);
4223 lbound = gfc_evaluate_now (lbse.expr, &block);
4227 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4228 lbound = gfc_conv_descriptor_lbound_get (tmp,
4232 lbound = gfc_conv_descriptor_lbound_get (dest,
4235 lbound = gfc_index_one_node;
4237 lbound = fold_convert (gfc_array_index_type, lbound);
4239 /* Shift the bounds and set the offset accordingly. */
4240 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4241 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4242 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4243 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4244 gfc_conv_descriptor_ubound_set (&block, dest,
4245 gfc_rank_cst[n], tmp);
4246 gfc_conv_descriptor_lbound_set (&block, dest,
4247 gfc_rank_cst[n], lbound);
4249 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4250 gfc_conv_descriptor_lbound_get (dest,
4252 gfc_conv_descriptor_stride_get (dest,
4254 gfc_add_modify (&block, tmp2, tmp);
4255 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4256 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4261 /* If a conversion expression has a null data pointer
4262 argument, nullify the allocatable component. */
4266 if (arg->symtree->n.sym->attr.allocatable
4267 || arg->symtree->n.sym->attr.pointer)
4269 non_null_expr = gfc_finish_block (&block);
4270 gfc_start_block (&block);
4271 gfc_conv_descriptor_data_set (&block, dest,
4273 null_expr = gfc_finish_block (&block);
4274 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4275 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4276 fold_convert (TREE_TYPE (tmp),
4277 null_pointer_node));
4278 return build3_v (COND_EXPR, tmp,
4279 null_expr, non_null_expr);
4283 return gfc_finish_block (&block);
4287 /* Assign a single component of a derived type constructor. */
4290 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4298 gfc_start_block (&block);
4300 if (cm->attr.pointer)
4302 gfc_init_se (&se, NULL);
4303 /* Pointer component. */
4304 if (cm->attr.dimension)
4306 /* Array pointer. */
4307 if (expr->expr_type == EXPR_NULL)
4308 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4311 rss = gfc_walk_expr (expr);
4312 se.direct_byref = 1;
4314 gfc_conv_expr_descriptor (&se, expr, rss);
4315 gfc_add_block_to_block (&block, &se.pre);
4316 gfc_add_block_to_block (&block, &se.post);
4321 /* Scalar pointers. */
4322 se.want_pointer = 1;
4323 gfc_conv_expr (&se, expr);
4324 gfc_add_block_to_block (&block, &se.pre);
4325 gfc_add_modify (&block, dest,
4326 fold_convert (TREE_TYPE (dest), se.expr));
4327 gfc_add_block_to_block (&block, &se.post);
4330 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4332 /* NULL initialization for CLASS components. */
4333 tmp = gfc_trans_structure_assign (dest,
4334 gfc_default_initializer (&cm->ts));
4335 gfc_add_expr_to_block (&block, tmp);
4337 else if (cm->attr.dimension)
4339 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4340 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4341 else if (cm->attr.allocatable)
4343 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4344 gfc_add_expr_to_block (&block, tmp);
4348 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4349 gfc_add_expr_to_block (&block, tmp);
4352 else if (expr->ts.type == BT_DERIVED)
4354 if (expr->expr_type != EXPR_STRUCTURE)
4356 gfc_init_se (&se, NULL);
4357 gfc_conv_expr (&se, expr);
4358 gfc_add_block_to_block (&block, &se.pre);
4359 gfc_add_modify (&block, dest,
4360 fold_convert (TREE_TYPE (dest), se.expr));
4361 gfc_add_block_to_block (&block, &se.post);
4365 /* Nested constructors. */
4366 tmp = gfc_trans_structure_assign (dest, expr);
4367 gfc_add_expr_to_block (&block, tmp);
4372 /* Scalar component. */
4373 gfc_init_se (&se, NULL);
4374 gfc_init_se (&lse, NULL);
4376 gfc_conv_expr (&se, expr);
4377 if (cm->ts.type == BT_CHARACTER)
4378 lse.string_length = cm->ts.u.cl->backend_decl;
4380 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4381 gfc_add_expr_to_block (&block, tmp);
4383 return gfc_finish_block (&block);
4386 /* Assign a derived type constructor to a variable. */
4389 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4397 gfc_start_block (&block);
4398 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. */
4406 /* Handle c_null_(fun)ptr. */
4407 if (c && c->expr && c->expr->ts.is_iso_c)
4409 field = cm->backend_decl;
4410 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4411 dest, field, NULL_TREE);
4412 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4413 fold_convert (TREE_TYPE (tmp),
4414 null_pointer_node));
4415 gfc_add_expr_to_block (&block, tmp);
4419 field = cm->backend_decl;
4420 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4421 dest, field, NULL_TREE);
4422 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4423 gfc_add_expr_to_block (&block, tmp);
4425 return gfc_finish_block (&block);
4428 /* Build an expression for a constructor. If init is nonzero then
4429 this is part of a static variable initializer. */
4432 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4439 VEC(constructor_elt,gc) *v = NULL;
4441 gcc_assert (se->ss == NULL);
4442 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4443 type = gfc_typenode_for_spec (&expr->ts);
4447 /* Create a temporary variable and fill it in. */
4448 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4449 tmp = gfc_trans_structure_assign (se->expr, expr);
4450 gfc_add_expr_to_block (&se->pre, tmp);
4454 cm = expr->ts.u.derived->components;
4456 for (c = gfc_constructor_first (expr->value.constructor);
4457 c; c = gfc_constructor_next (c), cm = cm->next)
4459 /* Skip absent members in default initializers and allocatable
4460 components. Although the latter have a default initializer
4461 of EXPR_NULL,... by default, the static nullify is not needed
4462 since this is done every time we come into scope. */
4463 if (!c->expr || cm->attr.allocatable)
4466 if (cm->ts.type == BT_CLASS)
4468 gfc_component *data;
4469 data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
4470 if (!data->backend_decl)
4471 gfc_get_derived_type (cm->ts.u.derived);
4472 val = gfc_conv_initializer (c->expr, &cm->ts,
4473 TREE_TYPE (data->backend_decl),
4474 data->attr.dimension,
4475 data->attr.pointer);
4477 CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
4479 else if (strcmp (cm->name, "$size") == 0)
4481 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4482 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4484 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4485 && strcmp (cm->name, "$extends") == 0)
4488 vtabs = cm->initializer->symtree->n.sym;
4489 val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4490 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4494 val = gfc_conv_initializer (c->expr, &cm->ts,
4495 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4496 cm->attr.pointer || cm->attr.proc_pointer);
4498 /* Append it to the constructor list. */
4499 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4502 se->expr = build_constructor (type, v);
4504 TREE_CONSTANT (se->expr) = 1;
4508 /* Translate a substring expression. */
4511 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4517 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4519 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4520 expr->value.character.length,
4521 expr->value.character.string);
4523 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4524 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4527 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4531 /* Entry point for expression translation. Evaluates a scalar quantity.
4532 EXPR is the expression to be translated, and SE is the state structure if
4533 called from within the scalarized. */
4536 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4538 if (se->ss && se->ss->expr == expr
4539 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4541 /* Substitute a scalar expression evaluated outside the scalarization
4543 se->expr = se->ss->data.scalar.expr;
4544 se->string_length = se->ss->string_length;
4545 gfc_advance_se_ss_chain (se);
4549 /* We need to convert the expressions for the iso_c_binding derived types.
4550 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4551 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4552 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4553 updated to be an integer with a kind equal to the size of a (void *). */
4554 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4555 && expr->ts.u.derived->attr.is_iso_c)
4557 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4558 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4560 /* Set expr_type to EXPR_NULL, which will result in
4561 null_pointer_node being used below. */
4562 expr->expr_type = EXPR_NULL;
4566 /* Update the type/kind of the expression to be what the new
4567 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4568 expr->ts.type = expr->ts.u.derived->ts.type;
4569 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4570 expr->ts.kind = expr->ts.u.derived->ts.kind;
4574 switch (expr->expr_type)
4577 gfc_conv_expr_op (se, expr);
4581 gfc_conv_function_expr (se, expr);
4585 gfc_conv_constant (se, expr);
4589 gfc_conv_variable (se, expr);
4593 se->expr = null_pointer_node;
4596 case EXPR_SUBSTRING:
4597 gfc_conv_substring_expr (se, expr);
4600 case EXPR_STRUCTURE:
4601 gfc_conv_structure (se, expr, 0);
4605 gfc_conv_array_constructor_expr (se, expr);
4614 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4615 of an assignment. */
4617 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4619 gfc_conv_expr (se, expr);
4620 /* All numeric lvalues should have empty post chains. If not we need to
4621 figure out a way of rewriting an lvalue so that it has no post chain. */
4622 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4625 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4626 numeric expressions. Used for scalar values where inserting cleanup code
4629 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4633 gcc_assert (expr->ts.type != BT_CHARACTER);
4634 gfc_conv_expr (se, expr);
4637 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4638 gfc_add_modify (&se->pre, val, se->expr);
4640 gfc_add_block_to_block (&se->pre, &se->post);
4644 /* Helper to translate an expression and convert it to a particular type. */
4646 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4648 gfc_conv_expr_val (se, expr);
4649 se->expr = convert (type, se->expr);
4653 /* Converts an expression so that it can be passed by reference. Scalar
4657 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4661 if (se->ss && se->ss->expr == expr
4662 && se->ss->type == GFC_SS_REFERENCE)
4664 se->expr = se->ss->data.scalar.expr;
4665 se->string_length = se->ss->string_length;
4666 gfc_advance_se_ss_chain (se);
4670 if (expr->ts.type == BT_CHARACTER)
4672 gfc_conv_expr (se, expr);
4673 gfc_conv_string_parameter (se);
4677 if (expr->expr_type == EXPR_VARIABLE)
4679 se->want_pointer = 1;
4680 gfc_conv_expr (se, expr);
4683 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4684 gfc_add_modify (&se->pre, var, se->expr);
4685 gfc_add_block_to_block (&se->pre, &se->post);
4691 if (expr->expr_type == EXPR_FUNCTION
4692 && ((expr->value.function.esym
4693 && expr->value.function.esym->result->attr.pointer
4694 && !expr->value.function.esym->result->attr.dimension)
4695 || (!expr->value.function.esym
4696 && expr->symtree->n.sym->attr.pointer
4697 && !expr->symtree->n.sym->attr.dimension)))
4699 se->want_pointer = 1;
4700 gfc_conv_expr (se, expr);
4701 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4702 gfc_add_modify (&se->pre, var, se->expr);
4708 gfc_conv_expr (se, expr);
4710 /* Create a temporary var to hold the value. */
4711 if (TREE_CONSTANT (se->expr))
4713 tree tmp = se->expr;
4714 STRIP_TYPE_NOPS (tmp);
4715 var = build_decl (input_location,
4716 CONST_DECL, NULL, TREE_TYPE (tmp));
4717 DECL_INITIAL (var) = tmp;
4718 TREE_STATIC (var) = 1;
4723 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4724 gfc_add_modify (&se->pre, var, se->expr);
4726 gfc_add_block_to_block (&se->pre, &se->post);
4728 /* Take the address of that value. */
4729 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4734 gfc_trans_pointer_assign (gfc_code * code)
4736 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4740 /* Generate code for a pointer assignment. */
4743 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4754 gfc_start_block (&block);
4756 gfc_init_se (&lse, NULL);
4758 lss = gfc_walk_expr (expr1);
4759 rss = gfc_walk_expr (expr2);
4760 if (lss == gfc_ss_terminator)
4762 /* Scalar pointers. */
4763 lse.want_pointer = 1;
4764 gfc_conv_expr (&lse, expr1);
4765 gcc_assert (rss == gfc_ss_terminator);
4766 gfc_init_se (&rse, NULL);
4767 rse.want_pointer = 1;
4768 gfc_conv_expr (&rse, expr2);
4770 if (expr1->symtree->n.sym->attr.proc_pointer
4771 && expr1->symtree->n.sym->attr.dummy)
4772 lse.expr = build_fold_indirect_ref_loc (input_location,
4775 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4776 && expr2->symtree->n.sym->attr.dummy)
4777 rse.expr = build_fold_indirect_ref_loc (input_location,
4780 gfc_add_block_to_block (&block, &lse.pre);
4781 gfc_add_block_to_block (&block, &rse.pre);
4783 /* Check character lengths if character expression. The test is only
4784 really added if -fbounds-check is enabled. */
4785 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4786 && !expr1->symtree->n.sym->attr.proc_pointer
4787 && !gfc_is_proc_ptr_comp (expr1, NULL))
4789 gcc_assert (expr2->ts.type == BT_CHARACTER);
4790 gcc_assert (lse.string_length && rse.string_length);
4791 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4792 lse.string_length, rse.string_length,
4796 gfc_add_modify (&block, lse.expr,
4797 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4799 gfc_add_block_to_block (&block, &rse.post);
4800 gfc_add_block_to_block (&block, &lse.post);
4805 tree strlen_rhs = NULL_TREE;
4807 /* Array pointer. */
4808 gfc_conv_expr_descriptor (&lse, expr1, lss);
4809 strlen_lhs = lse.string_length;
4810 switch (expr2->expr_type)
4813 /* Just set the data pointer to null. */
4814 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4818 /* Assign directly to the pointer's descriptor. */
4819 lse.direct_byref = 1;
4820 gfc_conv_expr_descriptor (&lse, expr2, rss);
4821 strlen_rhs = lse.string_length;
4823 /* If this is a subreference array pointer assignment, use the rhs
4824 descriptor element size for the lhs span. */
4825 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4827 decl = expr1->symtree->n.sym->backend_decl;
4828 gfc_init_se (&rse, NULL);
4829 rse.descriptor_only = 1;
4830 gfc_conv_expr (&rse, expr2);
4831 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4832 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4833 if (!INTEGER_CST_P (tmp))
4834 gfc_add_block_to_block (&lse.post, &rse.pre);
4835 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4841 /* Assign to a temporary descriptor and then copy that
4842 temporary to the pointer. */
4844 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4847 lse.direct_byref = 1;
4848 gfc_conv_expr_descriptor (&lse, expr2, rss);
4849 strlen_rhs = lse.string_length;
4850 gfc_add_modify (&lse.pre, desc, tmp);
4854 gfc_add_block_to_block (&block, &lse.pre);
4856 /* Check string lengths if applicable. The check is only really added
4857 to the output code if -fbounds-check is enabled. */
4858 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4860 gcc_assert (expr2->ts.type == BT_CHARACTER);
4861 gcc_assert (strlen_lhs && strlen_rhs);
4862 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4863 strlen_lhs, strlen_rhs, &block);
4866 gfc_add_block_to_block (&block, &lse.post);
4868 return gfc_finish_block (&block);
4872 /* Makes sure se is suitable for passing as a function string parameter. */
4873 /* TODO: Need to check all callers of this function. It may be abused. */
4876 gfc_conv_string_parameter (gfc_se * se)
4880 if (TREE_CODE (se->expr) == STRING_CST)
4882 type = TREE_TYPE (TREE_TYPE (se->expr));
4883 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4887 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4889 if (TREE_CODE (se->expr) != INDIRECT_REF)
4891 type = TREE_TYPE (se->expr);
4892 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4896 type = gfc_get_character_type_len (gfc_default_character_kind,
4898 type = build_pointer_type (type);
4899 se->expr = gfc_build_addr_expr (type, se->expr);
4903 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4904 gcc_assert (se->string_length
4905 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4909 /* Generate code for assignment of scalar variables. Includes character
4910 strings and derived types with allocatable components.
4911 If you know that the LHS has no allocations, set dealloc to false. */
4914 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4915 bool l_is_temp, bool r_is_var, bool dealloc)
4921 gfc_init_block (&block);
4923 if (ts.type == BT_CHARACTER)
4928 if (lse->string_length != NULL_TREE)
4930 gfc_conv_string_parameter (lse);
4931 gfc_add_block_to_block (&block, &lse->pre);
4932 llen = lse->string_length;
4935 if (rse->string_length != NULL_TREE)
4937 gcc_assert (rse->string_length != NULL_TREE);
4938 gfc_conv_string_parameter (rse);
4939 gfc_add_block_to_block (&block, &rse->pre);
4940 rlen = rse->string_length;
4943 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4944 rse->expr, ts.kind);
4946 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4950 /* Are the rhs and the lhs the same? */
4953 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4954 gfc_build_addr_expr (NULL_TREE, lse->expr),
4955 gfc_build_addr_expr (NULL_TREE, rse->expr));
4956 cond = gfc_evaluate_now (cond, &lse->pre);
4959 /* Deallocate the lhs allocated components as long as it is not
4960 the same as the rhs. This must be done following the assignment
4961 to prevent deallocating data that could be used in the rhs
4963 if (!l_is_temp && dealloc)
4965 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4966 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4968 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4970 gfc_add_expr_to_block (&lse->post, tmp);
4973 gfc_add_block_to_block (&block, &rse->pre);
4974 gfc_add_block_to_block (&block, &lse->pre);
4976 gfc_add_modify (&block, lse->expr,
4977 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4979 /* Do a deep copy if the rhs is a variable, if it is not the
4983 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4984 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4986 gfc_add_expr_to_block (&block, tmp);
4989 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4991 gfc_add_block_to_block (&block, &lse->pre);
4992 gfc_add_block_to_block (&block, &rse->pre);
4993 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4994 gfc_add_modify (&block, lse->expr, tmp);
4998 gfc_add_block_to_block (&block, &lse->pre);
4999 gfc_add_block_to_block (&block, &rse->pre);
5001 gfc_add_modify (&block, lse->expr,
5002 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5005 gfc_add_block_to_block (&block, &lse->post);
5006 gfc_add_block_to_block (&block, &rse->post);
5008 return gfc_finish_block (&block);
5012 /* Try to translate array(:) = func (...), where func is a transformational
5013 array function, without using a temporary. Returns NULL is this isn't the
5017 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5022 bool seen_array_ref;
5024 gfc_component *comp = NULL;
5026 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5027 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5030 /* Elemental functions don't need a temporary anyway. */
5031 if (expr2->value.function.esym != NULL
5032 && expr2->value.function.esym->attr.elemental)
5035 /* Fail if rhs is not FULL or a contiguous section. */
5036 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5039 /* Fail if EXPR1 can't be expressed as a descriptor. */
5040 if (gfc_ref_needs_temporary_p (expr1->ref))
5043 /* Functions returning pointers need temporaries. */
5044 if (expr2->symtree->n.sym->attr.pointer
5045 || expr2->symtree->n.sym->attr.allocatable)
5048 /* Character array functions need temporaries unless the
5049 character lengths are the same. */
5050 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5052 if (expr1->ts.u.cl->length == NULL
5053 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5056 if (expr2->ts.u.cl->length == NULL
5057 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5060 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5061 expr2->ts.u.cl->length->value.integer) != 0)
5065 /* Check that no LHS component references appear during an array
5066 reference. This is needed because we do not have the means to
5067 span any arbitrary stride with an array descriptor. This check
5068 is not needed for the rhs because the function result has to be
5070 seen_array_ref = false;
5071 for (ref = expr1->ref; ref; ref = ref->next)
5073 if (ref->type == REF_ARRAY)
5074 seen_array_ref= true;
5075 else if (ref->type == REF_COMPONENT && seen_array_ref)
5079 /* Check for a dependency. */
5080 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5081 expr2->value.function.esym,
5082 expr2->value.function.actual,
5086 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5088 gcc_assert (expr2->value.function.isym
5089 || (gfc_is_proc_ptr_comp (expr2, &comp)
5090 && comp && comp->attr.dimension)
5091 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5092 && expr2->value.function.esym->result->attr.dimension));
5094 ss = gfc_walk_expr (expr1);
5095 gcc_assert (ss != gfc_ss_terminator);
5096 gfc_init_se (&se, NULL);
5097 gfc_start_block (&se.pre);
5098 se.want_pointer = 1;
5100 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5102 if (expr1->ts.type == BT_DERIVED
5103 && expr1->ts.u.derived->attr.alloc_comp)
5106 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5108 gfc_add_expr_to_block (&se.pre, tmp);
5111 se.direct_byref = 1;
5112 se.ss = gfc_walk_expr (expr2);
5113 gcc_assert (se.ss != gfc_ss_terminator);
5114 gfc_conv_function_expr (&se, expr2);
5115 gfc_add_block_to_block (&se.pre, &se.post);
5117 return gfc_finish_block (&se.pre);
5121 /* Try to efficiently translate array(:) = 0. Return NULL if this
5125 gfc_trans_zero_assign (gfc_expr * expr)
5127 tree dest, len, type;
5131 sym = expr->symtree->n.sym;
5132 dest = gfc_get_symbol_decl (sym);
5134 type = TREE_TYPE (dest);
5135 if (POINTER_TYPE_P (type))
5136 type = TREE_TYPE (type);
5137 if (!GFC_ARRAY_TYPE_P (type))
5140 /* Determine the length of the array. */
5141 len = GFC_TYPE_ARRAY_SIZE (type);
5142 if (!len || TREE_CODE (len) != INTEGER_CST)
5145 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5146 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5147 fold_convert (gfc_array_index_type, tmp));
5149 /* If we are zeroing a local array avoid taking its address by emitting
5151 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5152 return build2 (MODIFY_EXPR, void_type_node,
5153 dest, build_constructor (TREE_TYPE (dest), NULL));
5155 /* Convert arguments to the correct types. */
5156 dest = fold_convert (pvoid_type_node, dest);
5157 len = fold_convert (size_type_node, len);
5159 /* Construct call to __builtin_memset. */
5160 tmp = build_call_expr_loc (input_location,
5161 built_in_decls[BUILT_IN_MEMSET],
5162 3, dest, integer_zero_node, len);
5163 return fold_convert (void_type_node, tmp);
5167 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5168 that constructs the call to __builtin_memcpy. */
5171 gfc_build_memcpy_call (tree dst, tree src, tree len)
5175 /* Convert arguments to the correct types. */
5176 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5177 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5179 dst = fold_convert (pvoid_type_node, dst);
5181 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5182 src = gfc_build_addr_expr (pvoid_type_node, src);
5184 src = fold_convert (pvoid_type_node, src);
5186 len = fold_convert (size_type_node, len);
5188 /* Construct call to __builtin_memcpy. */
5189 tmp = build_call_expr_loc (input_location,
5190 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5191 return fold_convert (void_type_node, tmp);
5195 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5196 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5197 source/rhs, both are gfc_full_array_ref_p which have been checked for
5201 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5203 tree dst, dlen, dtype;
5204 tree src, slen, stype;
5207 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5208 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5210 dtype = TREE_TYPE (dst);
5211 if (POINTER_TYPE_P (dtype))
5212 dtype = TREE_TYPE (dtype);
5213 stype = TREE_TYPE (src);
5214 if (POINTER_TYPE_P (stype))
5215 stype = TREE_TYPE (stype);
5217 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5220 /* Determine the lengths of the arrays. */
5221 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5222 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5224 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5225 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5226 fold_convert (gfc_array_index_type, tmp));
5228 slen = GFC_TYPE_ARRAY_SIZE (stype);
5229 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5231 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5232 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5233 fold_convert (gfc_array_index_type, tmp));
5235 /* Sanity check that they are the same. This should always be
5236 the case, as we should already have checked for conformance. */
5237 if (!tree_int_cst_equal (slen, dlen))
5240 return gfc_build_memcpy_call (dst, src, dlen);
5244 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5245 this can't be done. EXPR1 is the destination/lhs for which
5246 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5249 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5251 unsigned HOST_WIDE_INT nelem;
5257 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5261 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5262 dtype = TREE_TYPE (dst);
5263 if (POINTER_TYPE_P (dtype))
5264 dtype = TREE_TYPE (dtype);
5265 if (!GFC_ARRAY_TYPE_P (dtype))
5268 /* Determine the lengths of the array. */
5269 len = GFC_TYPE_ARRAY_SIZE (dtype);
5270 if (!len || TREE_CODE (len) != INTEGER_CST)
5273 /* Confirm that the constructor is the same size. */
5274 if (compare_tree_int (len, nelem) != 0)
5277 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5278 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5279 fold_convert (gfc_array_index_type, tmp));
5281 stype = gfc_typenode_for_spec (&expr2->ts);
5282 src = gfc_build_constant_array_constructor (expr2, stype);
5284 stype = TREE_TYPE (src);
5285 if (POINTER_TYPE_P (stype))
5286 stype = TREE_TYPE (stype);
5288 return gfc_build_memcpy_call (dst, src, len);
5292 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5293 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5294 init_flag indicates initialization expressions and dealloc that no
5295 deallocate prior assignment is needed (if in doubt, set true). */
5298 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5304 gfc_ss *lss_section;
5311 bool scalar_to_array;
5314 /* Assignment of the form lhs = rhs. */
5315 gfc_start_block (&block);
5317 gfc_init_se (&lse, NULL);
5318 gfc_init_se (&rse, NULL);
5321 lss = gfc_walk_expr (expr1);
5323 if (lss != gfc_ss_terminator)
5325 /* Allow the scalarizer to workshare array assignments. */
5326 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5327 ompws_flags |= OMPWS_SCALARIZER_WS;
5329 /* The assignment needs scalarization. */
5332 /* Find a non-scalar SS from the lhs. */
5333 while (lss_section != gfc_ss_terminator
5334 && lss_section->type != GFC_SS_SECTION)
5335 lss_section = lss_section->next;
5337 gcc_assert (lss_section != gfc_ss_terminator);
5339 /* Initialize the scalarizer. */
5340 gfc_init_loopinfo (&loop);
5343 rss = gfc_walk_expr (expr2);
5344 if (rss == gfc_ss_terminator)
5346 /* The rhs is scalar. Add a ss for the expression. */
5347 rss = gfc_get_ss ();
5348 rss->next = gfc_ss_terminator;
5349 rss->type = GFC_SS_SCALAR;
5352 /* Associate the SS with the loop. */
5353 gfc_add_ss_to_loop (&loop, lss);
5354 gfc_add_ss_to_loop (&loop, rss);
5356 /* Calculate the bounds of the scalarization. */
5357 gfc_conv_ss_startstride (&loop);
5358 /* Resolve any data dependencies in the statement. */
5359 gfc_conv_resolve_dependencies (&loop, lss, rss);
5360 /* Setup the scalarizing loops. */
5361 gfc_conv_loop_setup (&loop, &expr2->where);
5363 /* Setup the gfc_se structures. */
5364 gfc_copy_loopinfo_to_se (&lse, &loop);
5365 gfc_copy_loopinfo_to_se (&rse, &loop);
5368 gfc_mark_ss_chain_used (rss, 1);
5369 if (loop.temp_ss == NULL)
5372 gfc_mark_ss_chain_used (lss, 1);
5376 lse.ss = loop.temp_ss;
5377 gfc_mark_ss_chain_used (lss, 3);
5378 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5381 /* Start the scalarized loop body. */
5382 gfc_start_scalarized_body (&loop, &body);
5385 gfc_init_block (&body);
5387 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5389 /* Translate the expression. */
5390 gfc_conv_expr (&rse, expr2);
5392 /* Stabilize a string length for temporaries. */
5393 if (expr2->ts.type == BT_CHARACTER)
5394 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5396 string_length = NULL_TREE;
5400 gfc_conv_tmp_array_ref (&lse);
5401 gfc_advance_se_ss_chain (&lse);
5402 if (expr2->ts.type == BT_CHARACTER)
5403 lse.string_length = string_length;
5406 gfc_conv_expr (&lse, expr1);
5408 /* Assignments of scalar derived types with allocatable components
5409 to arrays must be done with a deep copy and the rhs temporary
5410 must have its components deallocated afterwards. */
5411 scalar_to_array = (expr2->ts.type == BT_DERIVED
5412 && expr2->ts.u.derived->attr.alloc_comp
5413 && expr2->expr_type != EXPR_VARIABLE
5414 && !gfc_is_constant_expr (expr2)
5415 && expr1->rank && !expr2->rank);
5416 if (scalar_to_array && dealloc)
5418 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5419 gfc_add_expr_to_block (&loop.post, tmp);
5422 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5423 l_is_temp || init_flag,
5424 (expr2->expr_type == EXPR_VARIABLE)
5425 || scalar_to_array, dealloc);
5426 gfc_add_expr_to_block (&body, tmp);
5428 if (lss == gfc_ss_terminator)
5430 /* Use the scalar assignment as is. */
5431 gfc_add_block_to_block (&block, &body);
5435 gcc_assert (lse.ss == gfc_ss_terminator
5436 && rse.ss == gfc_ss_terminator);
5440 gfc_trans_scalarized_loop_boundary (&loop, &body);
5442 /* We need to copy the temporary to the actual lhs. */
5443 gfc_init_se (&lse, NULL);
5444 gfc_init_se (&rse, NULL);
5445 gfc_copy_loopinfo_to_se (&lse, &loop);
5446 gfc_copy_loopinfo_to_se (&rse, &loop);
5448 rse.ss = loop.temp_ss;
5451 gfc_conv_tmp_array_ref (&rse);
5452 gfc_advance_se_ss_chain (&rse);
5453 gfc_conv_expr (&lse, expr1);
5455 gcc_assert (lse.ss == gfc_ss_terminator
5456 && rse.ss == gfc_ss_terminator);
5458 if (expr2->ts.type == BT_CHARACTER)
5459 rse.string_length = string_length;
5461 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5462 false, false, dealloc);
5463 gfc_add_expr_to_block (&body, tmp);
5466 /* Generate the copying loops. */
5467 gfc_trans_scalarizing_loops (&loop, &body);
5469 /* Wrap the whole thing up. */
5470 gfc_add_block_to_block (&block, &loop.pre);
5471 gfc_add_block_to_block (&block, &loop.post);
5473 gfc_cleanup_loop (&loop);
5476 return gfc_finish_block (&block);
5480 /* Check whether EXPR is a copyable array. */
5483 copyable_array_p (gfc_expr * expr)
5485 if (expr->expr_type != EXPR_VARIABLE)
5488 /* First check it's an array. */
5489 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5492 if (!gfc_full_array_ref_p (expr->ref, NULL))
5495 /* Next check that it's of a simple enough type. */
5496 switch (expr->ts.type)
5508 return !expr->ts.u.derived->attr.alloc_comp;
5517 /* Translate an assignment. */
5520 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5525 /* Special case a single function returning an array. */
5526 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5528 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5533 /* Special case assigning an array to zero. */
5534 if (copyable_array_p (expr1)
5535 && is_zero_initializer_p (expr2))
5537 tmp = gfc_trans_zero_assign (expr1);
5542 /* Special case copying one array to another. */
5543 if (copyable_array_p (expr1)
5544 && copyable_array_p (expr2)
5545 && gfc_compare_types (&expr1->ts, &expr2->ts)
5546 && !gfc_check_dependency (expr1, expr2, 0))
5548 tmp = gfc_trans_array_copy (expr1, expr2);
5553 /* Special case initializing an array from a constant array constructor. */
5554 if (copyable_array_p (expr1)
5555 && expr2->expr_type == EXPR_ARRAY
5556 && gfc_compare_types (&expr1->ts, &expr2->ts))
5558 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5563 /* Fallback to the scalarizer to generate explicit loops. */
5564 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5568 gfc_trans_init_assign (gfc_code * code)
5570 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5574 gfc_trans_assign (gfc_code * code)
5576 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5580 /* Translate an assignment to a CLASS object
5581 (pointer or ordinary assignment). */
5584 gfc_trans_class_assign (gfc_code *code)
5591 gfc_start_block (&block);
5593 if (code->op == EXEC_INIT_ASSIGN)
5595 /* Special case for initializing a CLASS variable on allocation.
5596 A MEMCPY is needed to copy the full data of the dynamic type,
5597 which may be different from the declared type. */
5600 gfc_init_se (&dst, NULL);
5601 gfc_init_se (&src, NULL);
5602 gfc_add_component_ref (code->expr1, "$data");
5603 gfc_conv_expr (&dst, code->expr1);
5604 gfc_conv_expr (&src, code->expr2);
5605 gfc_add_block_to_block (&block, &src.pre);
5606 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5607 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5608 gfc_add_expr_to_block (&block, tmp);
5609 return gfc_finish_block (&block);
5612 if (code->expr2->ts.type != BT_CLASS)
5614 /* Insert an additional assignment which sets the '$vptr' field. */
5615 lhs = gfc_copy_expr (code->expr1);
5616 gfc_add_component_ref (lhs, "$vptr");
5617 if (code->expr2->ts.type == BT_DERIVED)
5621 vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
5624 rhs = gfc_get_expr ();
5625 rhs->expr_type = EXPR_VARIABLE;
5626 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5630 else if (code->expr2->expr_type == EXPR_NULL)
5631 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5635 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5636 gfc_add_expr_to_block (&block, tmp);
5638 gfc_free_expr (lhs);
5639 gfc_free_expr (rhs);
5642 /* Do the actual CLASS assignment. */
5643 if (code->expr2->ts.type == BT_CLASS)
5644 code->op = EXEC_ASSIGN;
5646 gfc_add_component_ref (code->expr1, "$data");
5648 if (code->op == EXEC_ASSIGN)
5649 tmp = gfc_trans_assign (code);
5650 else if (code->op == EXEC_POINTER_ASSIGN)
5651 tmp = gfc_trans_pointer_assign (code);
5655 gfc_add_expr_to_block (&block, tmp);
5657 return gfc_finish_block (&block);