1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym->attr.pointer && !sym->attr.allocatable
148 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
149 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
152 tmp = build_fold_indirect_ref_loc (input_location, decl);
153 tmp = gfc_conv_array_data (tmp);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 fold_convert (TREE_TYPE (tmp), null_pointer_node));
156 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
157 boolean_type_node, cond, tmp);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
172 present = gfc_conv_expr_present (arg->symtree->n.sym);
176 /* Create a temporary and convert it to the correct type. */
177 tmp = gfc_get_int_type (kind);
178 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
181 /* Test for a NULL value. */
182 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
183 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
189 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
191 build_zero_cst (TREE_TYPE (se->expr)));
192 tmp = gfc_evaluate_now (tmp, &se->pre);
196 if (ts.type == BT_CHARACTER)
198 tmp = build_int_cst (gfc_charlen_type_node, 0);
199 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
200 present, se->string_length, tmp);
201 tmp = gfc_evaluate_now (tmp, &se->pre);
202 se->string_length = tmp;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr *e)
217 gcc_assert (e->expr_type == EXPR_VARIABLE
218 && e->ts.type == BT_CHARACTER);
220 length = NULL; /* To silence compiler warning. */
222 if (is_subref_array (e) && e->ts.u.cl->length)
225 gfc_init_se (&tmpse, NULL);
226 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
227 e->ts.u.cl->backend_decl = tmpse.expr;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
235 length = e->symtree->n.sym->ts.u.cl->backend_decl;
237 /* Look through the reference chain for component references. */
238 for (r = e->ref; r; r = r->next)
243 if (r->u.c.component->ts.type == BT_CHARACTER)
244 length = r->u.c.component->ts.u.cl->backend_decl;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length != NULL);
264 /* For each character array constructor subexpression without a ts.u.cl->length,
265 replace it by its first element (if there aren't any elements, the length
266 should already be set to zero). */
269 flatten_array_ctors_without_strlen (gfc_expr* e)
271 gfc_actual_arglist* arg;
277 switch (e->expr_type)
281 flatten_array_ctors_without_strlen (e->value.op.op1);
282 flatten_array_ctors_without_strlen (e->value.op.op2);
286 /* TODO: Implement as with EXPR_FUNCTION when needed. */
290 for (arg = e->value.function.actual; arg; arg = arg->next)
291 flatten_array_ctors_without_strlen (arg->expr);
296 /* We've found what we're looking for. */
297 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
302 gcc_assert (e->value.constructor);
304 c = gfc_constructor_first (e->value.constructor);
308 flatten_array_ctors_without_strlen (new_expr);
309 gfc_replace_expr (e, new_expr);
313 /* Otherwise, fall through to handle constructor elements. */
315 for (c = gfc_constructor_first (e->value.constructor);
316 c; c = gfc_constructor_next (c))
317 flatten_array_ctors_without_strlen (c->expr);
327 /* Generate code to initialize a string length variable. Returns the
328 value. For array constructors, cl->length might be NULL and in this case,
329 the first element of the constructor is needed. expr is the original
330 expression so we can access it but can be NULL if this is not needed. */
333 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
337 gfc_init_se (&se, NULL);
341 && TREE_CODE (cl->backend_decl) == VAR_DECL)
344 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
345 "flatten" array constructors by taking their first element; all elements
346 should be the same length or a cl->length should be present. */
351 expr_flat = gfc_copy_expr (expr);
352 flatten_array_ctors_without_strlen (expr_flat);
353 gfc_resolve_expr (expr_flat);
355 gfc_conv_expr (&se, expr_flat);
356 gfc_add_block_to_block (pblock, &se.pre);
357 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
359 gfc_free_expr (expr_flat);
363 /* Convert cl->length. */
365 gcc_assert (cl->length);
367 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
368 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
369 se.expr, build_int_cst (gfc_charlen_type_node, 0));
370 gfc_add_block_to_block (pblock, &se.pre);
372 if (cl->backend_decl)
373 gfc_add_modify (pblock, cl->backend_decl, se.expr);
375 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
380 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
381 const char *name, locus *where)
390 type = gfc_get_character_type (kind, ref->u.ss.length);
391 type = build_pointer_type (type);
393 gfc_init_se (&start, se);
394 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
395 gfc_add_block_to_block (&se->pre, &start.pre);
397 if (integer_onep (start.expr))
398 gfc_conv_string_parameter (se);
403 /* Avoid multiple evaluation of substring start. */
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 start.expr = gfc_evaluate_now (start.expr, &se->pre);
407 /* Change the start of the string. */
408 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
411 tmp = build_fold_indirect_ref_loc (input_location,
413 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
414 se->expr = gfc_build_addr_expr (type, tmp);
417 /* Length = end + 1 - start. */
418 gfc_init_se (&end, se);
419 if (ref->u.ss.end == NULL)
420 end.expr = se->string_length;
423 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
424 gfc_add_block_to_block (&se->pre, &end.pre);
428 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
429 end.expr = gfc_evaluate_now (end.expr, &se->pre);
431 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
433 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
434 boolean_type_node, start.expr,
437 /* Check lower bound. */
438 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
440 build_int_cst (gfc_charlen_type_node, 1));
441 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
442 boolean_type_node, nonempty, fault);
444 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
445 "is less than one", name);
447 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
449 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
450 fold_convert (long_integer_type_node,
454 /* Check upper bound. */
455 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
456 end.expr, se->string_length);
457 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
458 boolean_type_node, nonempty, fault);
460 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
461 "exceeds string length (%%ld)", name);
463 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
464 "exceeds string length (%%ld)");
465 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
466 fold_convert (long_integer_type_node, end.expr),
467 fold_convert (long_integer_type_node,
472 /* If the start and end expressions are equal, the length is one. */
474 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
475 tmp = build_int_cst (gfc_charlen_type_node, 1);
478 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
479 end.expr, start.expr);
480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
481 build_int_cst (gfc_charlen_type_node, 1), tmp);
482 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
483 tmp, build_int_cst (gfc_charlen_type_node, 0));
486 se->string_length = tmp;
490 /* Convert a derived type component reference. */
493 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
500 c = ref->u.c.component;
502 gcc_assert (c->backend_decl);
504 field = c->backend_decl;
505 gcc_assert (TREE_CODE (field) == FIELD_DECL);
508 /* Components can correspond to fields of different containing
509 types, as components are created without context, whereas
510 a concrete use of a component has the type of decl as context.
511 So, if the type doesn't match, we search the corresponding
512 FIELD_DECL in the parent type. To not waste too much time
513 we cache this result in norestrict_decl. */
515 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
517 tree f2 = c->norestrict_decl;
518 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
519 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
520 if (TREE_CODE (f2) == FIELD_DECL
521 && DECL_NAME (f2) == DECL_NAME (field))
524 c->norestrict_decl = f2;
527 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
528 decl, field, NULL_TREE);
532 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
534 tmp = c->ts.u.cl->backend_decl;
535 /* Components must always be constant length. */
536 gcc_assert (tmp && INTEGER_CST_P (tmp));
537 se->string_length = tmp;
540 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
541 && c->ts.type != BT_CHARACTER)
542 || c->attr.proc_pointer)
543 se->expr = build_fold_indirect_ref_loc (input_location,
548 /* This function deals with component references to components of the
549 parent type for derived type extensons. */
551 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
559 c = ref->u.c.component;
561 /* Return if the component is not in the parent type. */
562 for (cmp = dt->components; cmp; cmp = cmp->next)
563 if (strcmp (c->name, cmp->name) == 0)
566 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
567 parent.type = REF_COMPONENT;
570 parent.u.c.component = dt->components;
572 if (dt->backend_decl == NULL)
573 gfc_get_derived_type (dt);
575 /* Build the reference and call self. */
576 gfc_conv_component_ref (se, &parent);
577 parent.u.c.sym = dt->components->ts.u.derived;
578 parent.u.c.component = c;
579 conv_parent_component_references (se, &parent);
582 /* Return the contents of a variable. Also handles reference/pointer
583 variables (all Fortran pointer references are implicit). */
586 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
590 tree parent_decl = NULL_TREE;
593 bool alternate_entry;
596 sym = expr->symtree->n.sym;
599 /* Check that something hasn't gone horribly wrong. */
600 gcc_assert (se->ss != gfc_ss_terminator);
601 gcc_assert (se->ss->expr == expr);
603 /* A scalarized term. We already know the descriptor. */
604 se->expr = se->ss->data.info.descriptor;
605 se->string_length = se->ss->string_length;
606 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
607 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
612 tree se_expr = NULL_TREE;
614 se->expr = gfc_get_symbol_decl (sym);
616 /* Deal with references to a parent results or entries by storing
617 the current_function_decl and moving to the parent_decl. */
618 return_value = sym->attr.function && sym->result == sym;
619 alternate_entry = sym->attr.function && sym->attr.entry
620 && sym->result == sym;
621 entry_master = sym->attr.result
622 && sym->ns->proc_name->attr.entry_master
623 && !gfc_return_by_reference (sym->ns->proc_name);
624 if (current_function_decl)
625 parent_decl = DECL_CONTEXT (current_function_decl);
627 if ((se->expr == parent_decl && return_value)
628 || (sym->ns && sym->ns->proc_name
630 && sym->ns->proc_name->backend_decl == parent_decl
631 && (alternate_entry || entry_master)))
636 /* Special case for assigning the return value of a function.
637 Self recursive functions must have an explicit return value. */
638 if (return_value && (se->expr == current_function_decl || parent_flag))
639 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
641 /* Similarly for alternate entry points. */
642 else if (alternate_entry
643 && (sym->ns->proc_name->backend_decl == current_function_decl
646 gfc_entry_list *el = NULL;
648 for (el = sym->ns->entries; el; el = el->next)
651 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
656 else if (entry_master
657 && (sym->ns->proc_name->backend_decl == current_function_decl
659 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
664 /* Procedure actual arguments. */
665 else if (sym->attr.flavor == FL_PROCEDURE
666 && se->expr != current_function_decl)
668 if (!sym->attr.dummy && !sym->attr.proc_pointer)
670 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
671 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
677 /* Dereference the expression, where needed. Since characters
678 are entirely different from other types, they are treated
680 if (sym->ts.type == BT_CHARACTER)
682 /* Dereference character pointer dummy arguments
684 if ((sym->attr.pointer || sym->attr.allocatable)
686 || sym->attr.function
687 || sym->attr.result))
688 se->expr = build_fold_indirect_ref_loc (input_location,
692 else if (!sym->attr.value)
694 /* Dereference non-character scalar dummy arguments. */
695 if (sym->attr.dummy && !sym->attr.dimension
696 && !(sym->attr.codimension && sym->attr.allocatable))
697 se->expr = build_fold_indirect_ref_loc (input_location,
700 /* Dereference scalar hidden result. */
701 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
702 && (sym->attr.function || sym->attr.result)
703 && !sym->attr.dimension && !sym->attr.pointer
704 && !sym->attr.always_explicit)
705 se->expr = build_fold_indirect_ref_loc (input_location,
708 /* Dereference non-character pointer variables.
709 These must be dummies, results, or scalars. */
710 if ((sym->attr.pointer || sym->attr.allocatable
711 || gfc_is_associate_pointer (sym))
713 || sym->attr.function
715 || (!sym->attr.dimension
716 && (!sym->attr.codimension || !sym->attr.allocatable))))
717 se->expr = build_fold_indirect_ref_loc (input_location,
724 /* For character variables, also get the length. */
725 if (sym->ts.type == BT_CHARACTER)
727 /* If the character length of an entry isn't set, get the length from
728 the master function instead. */
729 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
730 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
732 se->string_length = sym->ts.u.cl->backend_decl;
733 gcc_assert (se->string_length);
741 /* Return the descriptor if that's what we want and this is an array
742 section reference. */
743 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
745 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
746 /* Return the descriptor for array pointers and allocations. */
748 && ref->next == NULL && (se->descriptor_only))
751 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
752 /* Return a pointer to an element. */
756 if (ref->u.c.sym->attr.extension)
757 conv_parent_component_references (se, ref);
759 gfc_conv_component_ref (se, ref);
763 gfc_conv_substring (se, ref, expr->ts.kind,
764 expr->symtree->name, &expr->where);
773 /* Pointer assignment, allocation or pass by reference. Arrays are handled
775 if (se->want_pointer)
777 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
778 gfc_conv_string_parameter (se);
780 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
785 /* Unary ops are easy... Or they would be if ! was a valid op. */
788 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
793 gcc_assert (expr->ts.type != BT_CHARACTER);
794 /* Initialize the operand. */
795 gfc_init_se (&operand, se);
796 gfc_conv_expr_val (&operand, expr->value.op.op1);
797 gfc_add_block_to_block (&se->pre, &operand.pre);
799 type = gfc_typenode_for_spec (&expr->ts);
801 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
802 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
803 All other unary operators have an equivalent GIMPLE unary operator. */
804 if (code == TRUTH_NOT_EXPR)
805 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
806 build_int_cst (type, 0));
808 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
812 /* Expand power operator to optimal multiplications when a value is raised
813 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
814 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
815 Programming", 3rd Edition, 1998. */
817 /* This code is mostly duplicated from expand_powi in the backend.
818 We establish the "optimal power tree" lookup table with the defined size.
819 The items in the table are the exponents used to calculate the index
820 exponents. Any integer n less than the value can get an "addition chain",
821 with the first node being one. */
822 #define POWI_TABLE_SIZE 256
824 /* The table is from builtins.c. */
825 static const unsigned char powi_table[POWI_TABLE_SIZE] =
827 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
828 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
829 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
830 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
831 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
832 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
833 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
834 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
835 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
836 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
837 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
838 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
839 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
840 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
841 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
842 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
843 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
844 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
845 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
846 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
847 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
848 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
849 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
850 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
851 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
852 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
853 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
854 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
855 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
856 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
857 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
858 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
861 /* If n is larger than lookup table's max index, we use the "window
863 #define POWI_WINDOW_SIZE 3
865 /* Recursive function to expand the power operator. The temporary
866 values are put in tmpvar. The function returns tmpvar[1] ** n. */
868 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
875 if (n < POWI_TABLE_SIZE)
880 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
881 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
885 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
886 op0 = gfc_conv_powi (se, n - digit, tmpvar);
887 op1 = gfc_conv_powi (se, digit, tmpvar);
891 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
895 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
896 tmp = gfc_evaluate_now (tmp, &se->pre);
898 if (n < POWI_TABLE_SIZE)
905 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
906 return 1. Else return 0 and a call to runtime library functions
907 will have to be built. */
909 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
914 tree vartmp[POWI_TABLE_SIZE];
916 unsigned HOST_WIDE_INT n;
919 /* If exponent is too large, we won't expand it anyway, so don't bother
920 with large integer values. */
921 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
924 m = double_int_to_shwi (TREE_INT_CST (rhs));
925 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
926 of the asymmetric range of the integer type. */
927 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
929 type = TREE_TYPE (lhs);
930 sgn = tree_int_cst_sgn (rhs);
932 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
933 || optimize_size) && (m > 2 || m < -1))
939 se->expr = gfc_build_const (type, integer_one_node);
943 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
944 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
946 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
947 lhs, build_int_cst (TREE_TYPE (lhs), -1));
948 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
949 lhs, build_int_cst (TREE_TYPE (lhs), 1));
952 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
955 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
956 boolean_type_node, tmp, cond);
957 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
958 tmp, build_int_cst (type, 1),
959 build_int_cst (type, 0));
963 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
964 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
965 build_int_cst (type, -1),
966 build_int_cst (type, 0));
967 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
968 cond, build_int_cst (type, 1), tmp);
972 memset (vartmp, 0, sizeof (vartmp));
976 tmp = gfc_build_const (type, integer_one_node);
977 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
981 se->expr = gfc_conv_powi (se, n, vartmp);
987 /* Power op (**). Constant integer exponent has special handling. */
990 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
992 tree gfc_int4_type_node;
995 int res_ikind_1, res_ikind_2;
1000 gfc_init_se (&lse, se);
1001 gfc_conv_expr_val (&lse, expr->value.op.op1);
1002 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1003 gfc_add_block_to_block (&se->pre, &lse.pre);
1005 gfc_init_se (&rse, se);
1006 gfc_conv_expr_val (&rse, expr->value.op.op2);
1007 gfc_add_block_to_block (&se->pre, &rse.pre);
1009 if (expr->value.op.op2->ts.type == BT_INTEGER
1010 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1011 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1014 gfc_int4_type_node = gfc_get_int_type (4);
1016 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1017 library routine. But in the end, we have to convert the result back
1018 if this case applies -- with res_ikind_K, we keep track whether operand K
1019 falls into this case. */
1023 kind = expr->value.op.op1->ts.kind;
1024 switch (expr->value.op.op2->ts.type)
1027 ikind = expr->value.op.op2->ts.kind;
1032 rse.expr = convert (gfc_int4_type_node, rse.expr);
1033 res_ikind_2 = ikind;
1055 if (expr->value.op.op1->ts.type == BT_INTEGER)
1057 lse.expr = convert (gfc_int4_type_node, lse.expr);
1084 switch (expr->value.op.op1->ts.type)
1087 if (kind == 3) /* Case 16 was not handled properly above. */
1089 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1093 /* Use builtins for real ** int4. */
1099 fndecl = built_in_decls[BUILT_IN_POWIF];
1103 fndecl = built_in_decls[BUILT_IN_POWI];
1107 fndecl = built_in_decls[BUILT_IN_POWIL];
1111 /* Use the __builtin_powil() only if real(kind=16) is
1112 actually the C long double type. */
1113 if (!gfc_real16_is_float128)
1114 fndecl = built_in_decls[BUILT_IN_POWIL];
1122 /* If we don't have a good builtin for this, go for the
1123 library function. */
1125 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1129 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1138 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1142 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1150 se->expr = build_call_expr_loc (input_location,
1151 fndecl, 2, lse.expr, rse.expr);
1153 /* Convert the result back if it is of wrong integer kind. */
1154 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1156 /* We want the maximum of both operand kinds as result. */
1157 if (res_ikind_1 < res_ikind_2)
1158 res_ikind_1 = res_ikind_2;
1159 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1164 /* Generate code to allocate a string temporary. */
1167 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1172 if (gfc_can_put_var_on_stack (len))
1174 /* Create a temporary variable to hold the result. */
1175 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1176 gfc_charlen_type_node, len,
1177 build_int_cst (gfc_charlen_type_node, 1));
1178 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1180 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1181 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1183 tmp = build_array_type (TREE_TYPE (type), tmp);
1185 var = gfc_create_var (tmp, "str");
1186 var = gfc_build_addr_expr (type, var);
1190 /* Allocate a temporary to hold the result. */
1191 var = gfc_create_var (type, "pstr");
1192 tmp = gfc_call_malloc (&se->pre, type,
1193 fold_build2_loc (input_location, MULT_EXPR,
1194 TREE_TYPE (len), len,
1195 fold_convert (TREE_TYPE (len),
1196 TYPE_SIZE (type))));
1197 gfc_add_modify (&se->pre, var, tmp);
1199 /* Free the temporary afterwards. */
1200 tmp = gfc_call_free (convert (pvoid_type_node, var));
1201 gfc_add_expr_to_block (&se->post, tmp);
1208 /* Handle a string concatenation operation. A temporary will be allocated to
1212 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1215 tree len, type, var, tmp, fndecl;
1217 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1218 && expr->value.op.op2->ts.type == BT_CHARACTER);
1219 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1221 gfc_init_se (&lse, se);
1222 gfc_conv_expr (&lse, expr->value.op.op1);
1223 gfc_conv_string_parameter (&lse);
1224 gfc_init_se (&rse, se);
1225 gfc_conv_expr (&rse, expr->value.op.op2);
1226 gfc_conv_string_parameter (&rse);
1228 gfc_add_block_to_block (&se->pre, &lse.pre);
1229 gfc_add_block_to_block (&se->pre, &rse.pre);
1231 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1232 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1233 if (len == NULL_TREE)
1235 len = fold_build2_loc (input_location, PLUS_EXPR,
1236 TREE_TYPE (lse.string_length),
1237 lse.string_length, rse.string_length);
1240 type = build_pointer_type (type);
1242 var = gfc_conv_string_tmp (se, type, len);
1244 /* Do the actual concatenation. */
1245 if (expr->ts.kind == 1)
1246 fndecl = gfor_fndecl_concat_string;
1247 else if (expr->ts.kind == 4)
1248 fndecl = gfor_fndecl_concat_string_char4;
1252 tmp = build_call_expr_loc (input_location,
1253 fndecl, 6, len, var, lse.string_length, lse.expr,
1254 rse.string_length, rse.expr);
1255 gfc_add_expr_to_block (&se->pre, tmp);
1257 /* Add the cleanup for the operands. */
1258 gfc_add_block_to_block (&se->pre, &rse.post);
1259 gfc_add_block_to_block (&se->pre, &lse.post);
1262 se->string_length = len;
1265 /* Translates an op expression. Common (binary) cases are handled by this
1266 function, others are passed on. Recursion is used in either case.
1267 We use the fact that (op1.ts == op2.ts) (except for the power
1269 Operators need no special handling for scalarized expressions as long as
1270 they call gfc_conv_simple_val to get their operands.
1271 Character strings get special handling. */
1274 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1276 enum tree_code code;
1285 switch (expr->value.op.op)
1287 case INTRINSIC_PARENTHESES:
1288 if ((expr->ts.type == BT_REAL
1289 || expr->ts.type == BT_COMPLEX)
1290 && gfc_option.flag_protect_parens)
1292 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1293 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1298 case INTRINSIC_UPLUS:
1299 gfc_conv_expr (se, expr->value.op.op1);
1302 case INTRINSIC_UMINUS:
1303 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1307 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1310 case INTRINSIC_PLUS:
1314 case INTRINSIC_MINUS:
1318 case INTRINSIC_TIMES:
1322 case INTRINSIC_DIVIDE:
1323 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1324 an integer, we must round towards zero, so we use a
1326 if (expr->ts.type == BT_INTEGER)
1327 code = TRUNC_DIV_EXPR;
1332 case INTRINSIC_POWER:
1333 gfc_conv_power_op (se, expr);
1336 case INTRINSIC_CONCAT:
1337 gfc_conv_concat_op (se, expr);
1341 code = TRUTH_ANDIF_EXPR;
1346 code = TRUTH_ORIF_EXPR;
1350 /* EQV and NEQV only work on logicals, but since we represent them
1351 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1353 case INTRINSIC_EQ_OS:
1361 case INTRINSIC_NE_OS:
1362 case INTRINSIC_NEQV:
1369 case INTRINSIC_GT_OS:
1376 case INTRINSIC_GE_OS:
1383 case INTRINSIC_LT_OS:
1390 case INTRINSIC_LE_OS:
1396 case INTRINSIC_USER:
1397 case INTRINSIC_ASSIGN:
1398 /* These should be converted into function calls by the frontend. */
1402 fatal_error ("Unknown intrinsic op");
1406 /* The only exception to this is **, which is handled separately anyway. */
1407 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1409 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1413 gfc_init_se (&lse, se);
1414 gfc_conv_expr (&lse, expr->value.op.op1);
1415 gfc_add_block_to_block (&se->pre, &lse.pre);
1418 gfc_init_se (&rse, se);
1419 gfc_conv_expr (&rse, expr->value.op.op2);
1420 gfc_add_block_to_block (&se->pre, &rse.pre);
1424 gfc_conv_string_parameter (&lse);
1425 gfc_conv_string_parameter (&rse);
1427 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1428 rse.string_length, rse.expr,
1429 expr->value.op.op1->ts.kind,
1431 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1432 gfc_add_block_to_block (&lse.post, &rse.post);
1435 type = gfc_typenode_for_spec (&expr->ts);
1439 /* The result of logical ops is always boolean_type_node. */
1440 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1441 lse.expr, rse.expr);
1442 se->expr = convert (type, tmp);
1445 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1447 /* Add the post blocks. */
1448 gfc_add_block_to_block (&se->post, &rse.post);
1449 gfc_add_block_to_block (&se->post, &lse.post);
1452 /* If a string's length is one, we convert it to a single character. */
1455 gfc_string_to_single_character (tree len, tree str, int kind)
1458 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1459 || !POINTER_TYPE_P (TREE_TYPE (str)))
1462 if (TREE_INT_CST_LOW (len) == 1)
1464 str = fold_convert (gfc_get_pchar_type (kind), str);
1465 return build_fold_indirect_ref_loc (input_location, str);
1469 && TREE_CODE (str) == ADDR_EXPR
1470 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1471 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1472 && array_ref_low_bound (TREE_OPERAND (str, 0))
1473 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1474 && TREE_INT_CST_LOW (len) > 1
1475 && TREE_INT_CST_LOW (len)
1476 == (unsigned HOST_WIDE_INT)
1477 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1479 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1480 ret = build_fold_indirect_ref_loc (input_location, ret);
1481 if (TREE_CODE (ret) == INTEGER_CST)
1483 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1484 int i, length = TREE_STRING_LENGTH (string_cst);
1485 const char *ptr = TREE_STRING_POINTER (string_cst);
1487 for (i = 1; i < length; i++)
1500 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1503 if (sym->backend_decl)
1505 /* This becomes the nominal_type in
1506 function.c:assign_parm_find_data_types. */
1507 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1508 /* This becomes the passed_type in
1509 function.c:assign_parm_find_data_types. C promotes char to
1510 integer for argument passing. */
1511 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1513 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1518 /* If we have a constant character expression, make it into an
1520 if ((*expr)->expr_type == EXPR_CONSTANT)
1525 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1526 (int)(*expr)->value.character.string[0]);
1527 if ((*expr)->ts.kind != gfc_c_int_kind)
1529 /* The expr needs to be compatible with a C int. If the
1530 conversion fails, then the 2 causes an ICE. */
1531 ts.type = BT_INTEGER;
1532 ts.kind = gfc_c_int_kind;
1533 gfc_convert_type (*expr, &ts, 2);
1536 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1538 if ((*expr)->ref == NULL)
1540 se->expr = gfc_string_to_single_character
1541 (build_int_cst (integer_type_node, 1),
1542 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1544 ((*expr)->symtree->n.sym)),
1549 gfc_conv_variable (se, *expr);
1550 se->expr = gfc_string_to_single_character
1551 (build_int_cst (integer_type_node, 1),
1552 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1560 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1561 if STR is a string literal, otherwise return -1. */
1564 gfc_optimize_len_trim (tree len, tree str, int kind)
1567 && TREE_CODE (str) == ADDR_EXPR
1568 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1569 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1570 && array_ref_low_bound (TREE_OPERAND (str, 0))
1571 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1572 && TREE_INT_CST_LOW (len) >= 1
1573 && TREE_INT_CST_LOW (len)
1574 == (unsigned HOST_WIDE_INT)
1575 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1577 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1578 folded = build_fold_indirect_ref_loc (input_location, folded);
1579 if (TREE_CODE (folded) == INTEGER_CST)
1581 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1582 int length = TREE_STRING_LENGTH (string_cst);
1583 const char *ptr = TREE_STRING_POINTER (string_cst);
1585 for (; length > 0; length--)
1586 if (ptr[length - 1] != ' ')
1595 /* Compare two strings. If they are all single characters, the result is the
1596 subtraction of them. Otherwise, we build a library call. */
1599 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1600 enum tree_code code)
1606 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1607 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1609 sc1 = gfc_string_to_single_character (len1, str1, kind);
1610 sc2 = gfc_string_to_single_character (len2, str2, kind);
1612 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1614 /* Deal with single character specially. */
1615 sc1 = fold_convert (integer_type_node, sc1);
1616 sc2 = fold_convert (integer_type_node, sc2);
1617 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1621 if ((code == EQ_EXPR || code == NE_EXPR)
1623 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1625 /* If one string is a string literal with LEN_TRIM longer
1626 than the length of the second string, the strings
1628 int len = gfc_optimize_len_trim (len1, str1, kind);
1629 if (len > 0 && compare_tree_int (len2, len) < 0)
1630 return integer_one_node;
1631 len = gfc_optimize_len_trim (len2, str2, kind);
1632 if (len > 0 && compare_tree_int (len1, len) < 0)
1633 return integer_one_node;
1636 /* Build a call for the comparison. */
1638 fndecl = gfor_fndecl_compare_string;
1640 fndecl = gfor_fndecl_compare_string_char4;
1644 return build_call_expr_loc (input_location, fndecl, 4,
1645 len1, str1, len2, str2);
1649 /* Return the backend_decl for a procedure pointer component. */
1652 get_proc_ptr_comp (gfc_expr *e)
1658 gfc_init_se (&comp_se, NULL);
1659 e2 = gfc_copy_expr (e);
1660 /* We have to restore the expr type later so that gfc_free_expr frees
1661 the exact same thing that was allocated.
1662 TODO: This is ugly. */
1663 old_type = e2->expr_type;
1664 e2->expr_type = EXPR_VARIABLE;
1665 gfc_conv_expr (&comp_se, e2);
1666 e2->expr_type = old_type;
1668 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1673 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1677 if (gfc_is_proc_ptr_comp (expr, NULL))
1678 tmp = get_proc_ptr_comp (expr);
1679 else if (sym->attr.dummy)
1681 tmp = gfc_get_symbol_decl (sym);
1682 if (sym->attr.proc_pointer)
1683 tmp = build_fold_indirect_ref_loc (input_location,
1685 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1686 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1690 if (!sym->backend_decl)
1691 sym->backend_decl = gfc_get_extern_function_decl (sym);
1693 tmp = sym->backend_decl;
1695 if (sym->attr.cray_pointee)
1697 /* TODO - make the cray pointee a pointer to a procedure,
1698 assign the pointer to it and use it for the call. This
1700 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1701 gfc_get_symbol_decl (sym->cp_pointer));
1702 tmp = gfc_evaluate_now (tmp, &se->pre);
1705 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1707 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1708 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1715 /* Initialize MAPPING. */
1718 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1720 mapping->syms = NULL;
1721 mapping->charlens = NULL;
1725 /* Free all memory held by MAPPING (but not MAPPING itself). */
1728 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1730 gfc_interface_sym_mapping *sym;
1731 gfc_interface_sym_mapping *nextsym;
1733 gfc_charlen *nextcl;
1735 for (sym = mapping->syms; sym; sym = nextsym)
1737 nextsym = sym->next;
1738 sym->new_sym->n.sym->formal = NULL;
1739 gfc_free_symbol (sym->new_sym->n.sym);
1740 gfc_free_expr (sym->expr);
1741 free (sym->new_sym);
1744 for (cl = mapping->charlens; cl; cl = nextcl)
1747 gfc_free_expr (cl->length);
1753 /* Return a copy of gfc_charlen CL. Add the returned structure to
1754 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1756 static gfc_charlen *
1757 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1760 gfc_charlen *new_charlen;
1762 new_charlen = gfc_get_charlen ();
1763 new_charlen->next = mapping->charlens;
1764 new_charlen->length = gfc_copy_expr (cl->length);
1766 mapping->charlens = new_charlen;
1771 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1772 array variable that can be used as the actual argument for dummy
1773 argument SYM. Add any initialization code to BLOCK. PACKED is as
1774 for gfc_get_nodesc_array_type and DATA points to the first element
1775 in the passed array. */
1778 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1779 gfc_packed packed, tree data)
1784 type = gfc_typenode_for_spec (&sym->ts);
1785 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1786 !sym->attr.target && !sym->attr.pointer
1787 && !sym->attr.proc_pointer);
1789 var = gfc_create_var (type, "ifm");
1790 gfc_add_modify (block, var, fold_convert (type, data));
1796 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1797 and offset of descriptorless array type TYPE given that it has the same
1798 size as DESC. Add any set-up code to BLOCK. */
1801 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1808 offset = gfc_index_zero_node;
1809 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1811 dim = gfc_rank_cst[n];
1812 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1813 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1815 GFC_TYPE_ARRAY_LBOUND (type, n)
1816 = gfc_conv_descriptor_lbound_get (desc, dim);
1817 GFC_TYPE_ARRAY_UBOUND (type, n)
1818 = gfc_conv_descriptor_ubound_get (desc, dim);
1820 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1822 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1823 gfc_array_index_type,
1824 gfc_conv_descriptor_ubound_get (desc, dim),
1825 gfc_conv_descriptor_lbound_get (desc, dim));
1826 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1827 gfc_array_index_type,
1828 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1829 tmp = gfc_evaluate_now (tmp, block);
1830 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1832 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1833 GFC_TYPE_ARRAY_LBOUND (type, n),
1834 GFC_TYPE_ARRAY_STRIDE (type, n));
1835 offset = fold_build2_loc (input_location, MINUS_EXPR,
1836 gfc_array_index_type, offset, tmp);
1838 offset = gfc_evaluate_now (offset, block);
1839 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1843 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1844 in SE. The caller may still use se->expr and se->string_length after
1845 calling this function. */
1848 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1849 gfc_symbol * sym, gfc_se * se,
1852 gfc_interface_sym_mapping *sm;
1856 gfc_symbol *new_sym;
1858 gfc_symtree *new_symtree;
1860 /* Create a new symbol to represent the actual argument. */
1861 new_sym = gfc_new_symbol (sym->name, NULL);
1862 new_sym->ts = sym->ts;
1863 new_sym->as = gfc_copy_array_spec (sym->as);
1864 new_sym->attr.referenced = 1;
1865 new_sym->attr.dimension = sym->attr.dimension;
1866 new_sym->attr.contiguous = sym->attr.contiguous;
1867 new_sym->attr.codimension = sym->attr.codimension;
1868 new_sym->attr.pointer = sym->attr.pointer;
1869 new_sym->attr.allocatable = sym->attr.allocatable;
1870 new_sym->attr.flavor = sym->attr.flavor;
1871 new_sym->attr.function = sym->attr.function;
1873 /* Ensure that the interface is available and that
1874 descriptors are passed for array actual arguments. */
1875 if (sym->attr.flavor == FL_PROCEDURE)
1877 new_sym->formal = expr->symtree->n.sym->formal;
1878 new_sym->attr.always_explicit
1879 = expr->symtree->n.sym->attr.always_explicit;
1882 /* Create a fake symtree for it. */
1884 new_symtree = gfc_new_symtree (&root, sym->name);
1885 new_symtree->n.sym = new_sym;
1886 gcc_assert (new_symtree == root);
1888 /* Create a dummy->actual mapping. */
1889 sm = XCNEW (gfc_interface_sym_mapping);
1890 sm->next = mapping->syms;
1892 sm->new_sym = new_symtree;
1893 sm->expr = gfc_copy_expr (expr);
1896 /* Stabilize the argument's value. */
1897 if (!sym->attr.function && se)
1898 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1900 if (sym->ts.type == BT_CHARACTER)
1902 /* Create a copy of the dummy argument's length. */
1903 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1904 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1906 /* If the length is specified as "*", record the length that
1907 the caller is passing. We should use the callee's length
1908 in all other cases. */
1909 if (!new_sym->ts.u.cl->length && se)
1911 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1912 new_sym->ts.u.cl->backend_decl = se->string_length;
1919 /* Use the passed value as-is if the argument is a function. */
1920 if (sym->attr.flavor == FL_PROCEDURE)
1923 /* If the argument is either a string or a pointer to a string,
1924 convert it to a boundless character type. */
1925 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1927 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1928 tmp = build_pointer_type (tmp);
1929 if (sym->attr.pointer)
1930 value = build_fold_indirect_ref_loc (input_location,
1934 value = fold_convert (tmp, value);
1937 /* If the argument is a scalar, a pointer to an array or an allocatable,
1939 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1940 value = build_fold_indirect_ref_loc (input_location,
1943 /* For character(*), use the actual argument's descriptor. */
1944 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1945 value = build_fold_indirect_ref_loc (input_location,
1948 /* If the argument is an array descriptor, use it to determine
1949 information about the actual argument's shape. */
1950 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1951 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1953 /* Get the actual argument's descriptor. */
1954 desc = build_fold_indirect_ref_loc (input_location,
1957 /* Create the replacement variable. */
1958 tmp = gfc_conv_descriptor_data_get (desc);
1959 value = gfc_get_interface_mapping_array (&se->pre, sym,
1962 /* Use DESC to work out the upper bounds, strides and offset. */
1963 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1966 /* Otherwise we have a packed array. */
1967 value = gfc_get_interface_mapping_array (&se->pre, sym,
1968 PACKED_FULL, se->expr);
1970 new_sym->backend_decl = value;
1974 /* Called once all dummy argument mappings have been added to MAPPING,
1975 but before the mapping is used to evaluate expressions. Pre-evaluate
1976 the length of each argument, adding any initialization code to PRE and
1977 any finalization code to POST. */
1980 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1981 stmtblock_t * pre, stmtblock_t * post)
1983 gfc_interface_sym_mapping *sym;
1987 for (sym = mapping->syms; sym; sym = sym->next)
1988 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1989 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1991 expr = sym->new_sym->n.sym->ts.u.cl->length;
1992 gfc_apply_interface_mapping_to_expr (mapping, expr);
1993 gfc_init_se (&se, NULL);
1994 gfc_conv_expr (&se, expr);
1995 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1996 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1997 gfc_add_block_to_block (pre, &se.pre);
1998 gfc_add_block_to_block (post, &se.post);
2000 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2005 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2009 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2010 gfc_constructor_base base)
2013 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2015 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2018 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2019 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2020 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2026 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2030 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2035 for (; ref; ref = ref->next)
2039 for (n = 0; n < ref->u.ar.dimen; n++)
2041 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2042 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2043 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2045 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2052 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2053 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2059 /* Convert intrinsic function calls into result expressions. */
2062 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2070 arg1 = expr->value.function.actual->expr;
2071 if (expr->value.function.actual->next)
2072 arg2 = expr->value.function.actual->next->expr;
2076 sym = arg1->symtree->n.sym;
2078 if (sym->attr.dummy)
2083 switch (expr->value.function.isym->id)
2086 /* TODO figure out why this condition is necessary. */
2087 if (sym->attr.function
2088 && (arg1->ts.u.cl->length == NULL
2089 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2090 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2093 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2097 if (!sym->as || sym->as->rank == 0)
2100 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2102 dup = mpz_get_si (arg2->value.integer);
2107 dup = sym->as->rank;
2111 for (; d < dup; d++)
2115 if (!sym->as->upper[d] || !sym->as->lower[d])
2117 gfc_free_expr (new_expr);
2121 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2122 gfc_get_int_expr (gfc_default_integer_kind,
2124 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2126 new_expr = gfc_multiply (new_expr, tmp);
2132 case GFC_ISYM_LBOUND:
2133 case GFC_ISYM_UBOUND:
2134 /* TODO These implementations of lbound and ubound do not limit if
2135 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2137 if (!sym->as || sym->as->rank == 0)
2140 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2141 d = mpz_get_si (arg2->value.integer) - 1;
2143 /* TODO: If the need arises, this could produce an array of
2147 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2149 if (sym->as->lower[d])
2150 new_expr = gfc_copy_expr (sym->as->lower[d]);
2154 if (sym->as->upper[d])
2155 new_expr = gfc_copy_expr (sym->as->upper[d]);
2163 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2167 gfc_replace_expr (expr, new_expr);
2173 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2174 gfc_interface_mapping * mapping)
2176 gfc_formal_arglist *f;
2177 gfc_actual_arglist *actual;
2179 actual = expr->value.function.actual;
2180 f = map_expr->symtree->n.sym->formal;
2182 for (; f && actual; f = f->next, actual = actual->next)
2187 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2190 if (map_expr->symtree->n.sym->attr.dimension)
2195 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2197 for (d = 0; d < as->rank; d++)
2199 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2200 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2203 expr->value.function.esym->as = as;
2206 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2208 expr->value.function.esym->ts.u.cl->length
2209 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2211 gfc_apply_interface_mapping_to_expr (mapping,
2212 expr->value.function.esym->ts.u.cl->length);
2217 /* EXPR is a copy of an expression that appeared in the interface
2218 associated with MAPPING. Walk it recursively looking for references to
2219 dummy arguments that MAPPING maps to actual arguments. Replace each such
2220 reference with a reference to the associated actual argument. */
2223 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2226 gfc_interface_sym_mapping *sym;
2227 gfc_actual_arglist *actual;
2232 /* Copying an expression does not copy its length, so do that here. */
2233 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2235 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2236 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2239 /* Apply the mapping to any references. */
2240 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2242 /* ...and to the expression's symbol, if it has one. */
2243 /* TODO Find out why the condition on expr->symtree had to be moved into
2244 the loop rather than being outside it, as originally. */
2245 for (sym = mapping->syms; sym; sym = sym->next)
2246 if (expr->symtree && sym->old == expr->symtree->n.sym)
2248 if (sym->new_sym->n.sym->backend_decl)
2249 expr->symtree = sym->new_sym;
2251 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2252 /* Replace base type for polymorphic arguments. */
2253 if (expr->ref && expr->ref->type == REF_COMPONENT
2254 && sym->expr && sym->expr->ts.type == BT_CLASS)
2255 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2258 /* ...and to subexpressions in expr->value. */
2259 switch (expr->expr_type)
2264 case EXPR_SUBSTRING:
2268 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2269 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2273 for (actual = expr->value.function.actual; actual; actual = actual->next)
2274 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2276 if (expr->value.function.esym == NULL
2277 && expr->value.function.isym != NULL
2278 && expr->value.function.actual->expr->symtree
2279 && gfc_map_intrinsic_function (expr, mapping))
2282 for (sym = mapping->syms; sym; sym = sym->next)
2283 if (sym->old == expr->value.function.esym)
2285 expr->value.function.esym = sym->new_sym->n.sym;
2286 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2287 expr->value.function.esym->result = sym->new_sym->n.sym;
2292 case EXPR_STRUCTURE:
2293 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2306 /* Evaluate interface expression EXPR using MAPPING. Store the result
2310 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2311 gfc_se * se, gfc_expr * expr)
2313 expr = gfc_copy_expr (expr);
2314 gfc_apply_interface_mapping_to_expr (mapping, expr);
2315 gfc_conv_expr (se, expr);
2316 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2317 gfc_free_expr (expr);
2321 /* Returns a reference to a temporary array into which a component of
2322 an actual argument derived type array is copied and then returned
2323 after the function call. */
2325 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2326 sym_intent intent, bool formal_ptr)
2344 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2346 gfc_init_se (&lse, NULL);
2347 gfc_init_se (&rse, NULL);
2349 /* Walk the argument expression. */
2350 rss = gfc_walk_expr (expr);
2352 gcc_assert (rss != gfc_ss_terminator);
2354 /* Initialize the scalarizer. */
2355 gfc_init_loopinfo (&loop);
2356 gfc_add_ss_to_loop (&loop, rss);
2358 /* Calculate the bounds of the scalarization. */
2359 gfc_conv_ss_startstride (&loop);
2361 /* Build an ss for the temporary. */
2362 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2363 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2365 base_type = gfc_typenode_for_spec (&expr->ts);
2366 if (GFC_ARRAY_TYPE_P (base_type)
2367 || GFC_DESCRIPTOR_TYPE_P (base_type))
2368 base_type = gfc_get_element_type (base_type);
2370 loop.temp_ss = gfc_get_ss ();;
2371 loop.temp_ss->type = GFC_SS_TEMP;
2372 loop.temp_ss->data.temp.type = base_type;
2374 if (expr->ts.type == BT_CHARACTER)
2375 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2377 loop.temp_ss->string_length = NULL;
2379 parmse->string_length = loop.temp_ss->string_length;
2380 loop.temp_ss->data.temp.dimen = loop.dimen;
2381 loop.temp_ss->next = gfc_ss_terminator;
2383 /* Associate the SS with the loop. */
2384 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2386 /* Setup the scalarizing loops. */
2387 gfc_conv_loop_setup (&loop, &expr->where);
2389 /* Pass the temporary descriptor back to the caller. */
2390 info = &loop.temp_ss->data.info;
2391 parmse->expr = info->descriptor;
2393 /* Setup the gfc_se structures. */
2394 gfc_copy_loopinfo_to_se (&lse, &loop);
2395 gfc_copy_loopinfo_to_se (&rse, &loop);
2398 lse.ss = loop.temp_ss;
2399 gfc_mark_ss_chain_used (rss, 1);
2400 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2402 /* Start the scalarized loop body. */
2403 gfc_start_scalarized_body (&loop, &body);
2405 /* Translate the expression. */
2406 gfc_conv_expr (&rse, expr);
2408 gfc_conv_tmp_array_ref (&lse);
2410 if (intent != INTENT_OUT)
2412 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2413 gfc_add_expr_to_block (&body, tmp);
2414 gcc_assert (rse.ss == gfc_ss_terminator);
2415 gfc_trans_scalarizing_loops (&loop, &body);
2419 /* Make sure that the temporary declaration survives by merging
2420 all the loop declarations into the current context. */
2421 for (n = 0; n < loop.dimen; n++)
2423 gfc_merge_block_scope (&body);
2424 body = loop.code[loop.order[n]];
2426 gfc_merge_block_scope (&body);
2429 /* Add the post block after the second loop, so that any
2430 freeing of allocated memory is done at the right time. */
2431 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2433 /**********Copy the temporary back again.*********/
2435 gfc_init_se (&lse, NULL);
2436 gfc_init_se (&rse, NULL);
2438 /* Walk the argument expression. */
2439 lss = gfc_walk_expr (expr);
2440 rse.ss = loop.temp_ss;
2443 /* Initialize the scalarizer. */
2444 gfc_init_loopinfo (&loop2);
2445 gfc_add_ss_to_loop (&loop2, lss);
2447 /* Calculate the bounds of the scalarization. */
2448 gfc_conv_ss_startstride (&loop2);
2450 /* Setup the scalarizing loops. */
2451 gfc_conv_loop_setup (&loop2, &expr->where);
2453 gfc_copy_loopinfo_to_se (&lse, &loop2);
2454 gfc_copy_loopinfo_to_se (&rse, &loop2);
2456 gfc_mark_ss_chain_used (lss, 1);
2457 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2459 /* Declare the variable to hold the temporary offset and start the
2460 scalarized loop body. */
2461 offset = gfc_create_var (gfc_array_index_type, NULL);
2462 gfc_start_scalarized_body (&loop2, &body);
2464 /* Build the offsets for the temporary from the loop variables. The
2465 temporary array has lbounds of zero and strides of one in all
2466 dimensions, so this is very simple. The offset is only computed
2467 outside the innermost loop, so the overall transfer could be
2468 optimized further. */
2469 info = &rse.ss->data.info;
2470 dimen = info->dimen;
2472 tmp_index = gfc_index_zero_node;
2473 for (n = dimen - 1; n > 0; n--)
2476 tmp = rse.loop->loopvar[n];
2477 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2478 tmp, rse.loop->from[n]);
2479 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2482 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2483 gfc_array_index_type,
2484 rse.loop->to[n-1], rse.loop->from[n-1]);
2485 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2486 gfc_array_index_type,
2487 tmp_str, gfc_index_one_node);
2489 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2490 gfc_array_index_type, tmp, tmp_str);
2493 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2494 gfc_array_index_type,
2495 tmp_index, rse.loop->from[0]);
2496 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2498 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2499 gfc_array_index_type,
2500 rse.loop->loopvar[0], offset);
2502 /* Now use the offset for the reference. */
2503 tmp = build_fold_indirect_ref_loc (input_location,
2505 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2507 if (expr->ts.type == BT_CHARACTER)
2508 rse.string_length = expr->ts.u.cl->backend_decl;
2510 gfc_conv_expr (&lse, expr);
2512 gcc_assert (lse.ss == gfc_ss_terminator);
2514 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2515 gfc_add_expr_to_block (&body, tmp);
2517 /* Generate the copying loops. */
2518 gfc_trans_scalarizing_loops (&loop2, &body);
2520 /* Wrap the whole thing up by adding the second loop to the post-block
2521 and following it by the post-block of the first loop. In this way,
2522 if the temporary needs freeing, it is done after use! */
2523 if (intent != INTENT_IN)
2525 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2526 gfc_add_block_to_block (&parmse->post, &loop2.post);
2529 gfc_add_block_to_block (&parmse->post, &loop.post);
2531 gfc_cleanup_loop (&loop);
2532 gfc_cleanup_loop (&loop2);
2534 /* Pass the string length to the argument expression. */
2535 if (expr->ts.type == BT_CHARACTER)
2536 parmse->string_length = expr->ts.u.cl->backend_decl;
2538 /* Determine the offset for pointer formal arguments and set the
2542 size = gfc_index_one_node;
2543 offset = gfc_index_zero_node;
2544 for (n = 0; n < dimen; n++)
2546 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2548 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2549 gfc_array_index_type, tmp,
2550 gfc_index_one_node);
2551 gfc_conv_descriptor_ubound_set (&parmse->pre,
2555 gfc_conv_descriptor_lbound_set (&parmse->pre,
2558 gfc_index_one_node);
2559 size = gfc_evaluate_now (size, &parmse->pre);
2560 offset = fold_build2_loc (input_location, MINUS_EXPR,
2561 gfc_array_index_type,
2563 offset = gfc_evaluate_now (offset, &parmse->pre);
2564 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2565 gfc_array_index_type,
2566 rse.loop->to[n], rse.loop->from[n]);
2567 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2568 gfc_array_index_type,
2569 tmp, gfc_index_one_node);
2570 size = fold_build2_loc (input_location, MULT_EXPR,
2571 gfc_array_index_type, size, tmp);
2574 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2578 /* We want either the address for the data or the address of the descriptor,
2579 depending on the mode of passing array arguments. */
2581 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2583 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2589 /* Generate the code for argument list functions. */
2592 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2594 /* Pass by value for g77 %VAL(arg), pass the address
2595 indirectly for %LOC, else by reference. Thus %REF
2596 is a "do-nothing" and %LOC is the same as an F95
2598 if (strncmp (name, "%VAL", 4) == 0)
2599 gfc_conv_expr (se, expr);
2600 else if (strncmp (name, "%LOC", 4) == 0)
2602 gfc_conv_expr_reference (se, expr);
2603 se->expr = gfc_build_addr_expr (NULL, se->expr);
2605 else if (strncmp (name, "%REF", 4) == 0)
2606 gfc_conv_expr_reference (se, expr);
2608 gfc_error ("Unknown argument list function at %L", &expr->where);
2612 /* Takes a derived type expression and returns the address of a temporary
2613 class object of the 'declared' type. */
2615 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2616 gfc_typespec class_ts)
2620 gfc_symbol *declared = class_ts.u.derived;
2626 /* The derived type needs to be converted to a temporary
2628 tmp = gfc_typenode_for_spec (&class_ts);
2629 var = gfc_create_var (tmp, "class");
2632 cmp = gfc_find_component (declared, "_vptr", true, true);
2633 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2634 TREE_TYPE (cmp->backend_decl),
2635 var, cmp->backend_decl, NULL_TREE);
2637 /* Remember the vtab corresponds to the derived type
2638 not to the class declared type. */
2639 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2641 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2642 gfc_add_modify (&parmse->pre, ctree,
2643 fold_convert (TREE_TYPE (ctree), tmp));
2645 /* Now set the data field. */
2646 cmp = gfc_find_component (declared, "_data", true, true);
2647 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2648 TREE_TYPE (cmp->backend_decl),
2649 var, cmp->backend_decl, NULL_TREE);
2650 ss = gfc_walk_expr (e);
2651 if (ss == gfc_ss_terminator)
2654 gfc_conv_expr_reference (parmse, e);
2655 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2656 gfc_add_modify (&parmse->pre, ctree, tmp);
2661 gfc_conv_expr (parmse, e);
2662 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2665 /* Pass the address of the class object. */
2666 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2670 /* The following routine generates code for the intrinsic
2671 procedures from the ISO_C_BINDING module:
2673 * C_FUNLOC (function)
2674 * C_F_POINTER (subroutine)
2675 * C_F_PROCPOINTER (subroutine)
2676 * C_ASSOCIATED (function)
2677 One exception which is not handled here is C_F_POINTER with non-scalar
2678 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2681 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2682 gfc_actual_arglist * arg)
2687 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2689 if (arg->expr->rank == 0)
2690 gfc_conv_expr_reference (se, arg->expr);
2694 /* This is really the actual arg because no formal arglist is
2695 created for C_LOC. */
2696 fsym = arg->expr->symtree->n.sym;
2698 /* We should want it to do g77 calling convention. */
2700 && !(fsym->attr.pointer || fsym->attr.allocatable)
2701 && fsym->as->type != AS_ASSUMED_SHAPE;
2702 f = f || !sym->attr.always_explicit;
2704 argss = gfc_walk_expr (arg->expr);
2705 gfc_conv_array_parameter (se, arg->expr, argss, f,
2709 /* TODO -- the following two lines shouldn't be necessary, but if
2710 they're removed, a bug is exposed later in the code path.
2711 This workaround was thus introduced, but will have to be
2712 removed; please see PR 35150 for details about the issue. */
2713 se->expr = convert (pvoid_type_node, se->expr);
2714 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2718 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2720 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2721 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2722 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2723 gfc_conv_expr_reference (se, arg->expr);
2727 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2728 && arg->next->expr->rank == 0)
2729 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2731 /* Convert c_f_pointer if fptr is a scalar
2732 and convert c_f_procpointer. */
2736 gfc_init_se (&cptrse, NULL);
2737 gfc_conv_expr (&cptrse, arg->expr);
2738 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2739 gfc_add_block_to_block (&se->post, &cptrse.post);
2741 gfc_init_se (&fptrse, NULL);
2742 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2743 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2744 fptrse.want_pointer = 1;
2746 gfc_conv_expr (&fptrse, arg->next->expr);
2747 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2748 gfc_add_block_to_block (&se->post, &fptrse.post);
2750 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2751 && arg->next->expr->symtree->n.sym->attr.dummy)
2752 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2755 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2756 TREE_TYPE (fptrse.expr),
2758 fold_convert (TREE_TYPE (fptrse.expr),
2763 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2768 /* Build the addr_expr for the first argument. The argument is
2769 already an *address* so we don't need to set want_pointer in
2771 gfc_init_se (&arg1se, NULL);
2772 gfc_conv_expr (&arg1se, arg->expr);
2773 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2774 gfc_add_block_to_block (&se->post, &arg1se.post);
2776 /* See if we were given two arguments. */
2777 if (arg->next == NULL)
2778 /* Only given one arg so generate a null and do a
2779 not-equal comparison against the first arg. */
2780 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2782 fold_convert (TREE_TYPE (arg1se.expr),
2783 null_pointer_node));
2789 /* Given two arguments so build the arg2se from second arg. */
2790 gfc_init_se (&arg2se, NULL);
2791 gfc_conv_expr (&arg2se, arg->next->expr);
2792 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2793 gfc_add_block_to_block (&se->post, &arg2se.post);
2795 /* Generate test to compare that the two args are equal. */
2796 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2797 arg1se.expr, arg2se.expr);
2798 /* Generate test to ensure that the first arg is not null. */
2799 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2801 arg1se.expr, null_pointer_node);
2803 /* Finally, the generated test must check that both arg1 is not
2804 NULL and that it is equal to the second arg. */
2805 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2807 not_null_expr, eq_expr);
2813 /* Nothing was done. */
2817 /* Generate code for a procedure call. Note can return se->post != NULL.
2818 If se->direct_byref is set then se->expr contains the return parameter.
2819 Return nonzero, if the call has alternate specifiers.
2820 'expr' is only needed for procedure pointer components. */
2823 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2824 gfc_actual_arglist * args, gfc_expr * expr,
2825 VEC(tree,gc) *append_args)
2827 gfc_interface_mapping mapping;
2828 VEC(tree,gc) *arglist;
2829 VEC(tree,gc) *retargs;
2840 VEC(tree,gc) *stringargs;
2842 gfc_formal_arglist *formal;
2843 gfc_actual_arglist *arg;
2844 int has_alternate_specifier = 0;
2845 bool need_interface_mapping;
2852 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2853 gfc_component *comp = NULL;
2863 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2864 && conv_isocbinding_procedure (se, sym, args))
2867 gfc_is_proc_ptr_comp (expr, &comp);
2871 if (!sym->attr.elemental)
2873 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2874 if (se->ss->useflags)
2876 gcc_assert ((!comp && gfc_return_by_reference (sym)
2877 && sym->result->attr.dimension)
2878 || (comp && comp->attr.dimension));
2879 gcc_assert (se->loop != NULL);
2881 /* Access the previously obtained result. */
2882 gfc_conv_tmp_array_ref (se);
2886 info = &se->ss->data.info;
2891 gfc_init_block (&post);
2892 gfc_init_interface_mapping (&mapping);
2895 formal = sym->formal;
2896 need_interface_mapping = sym->attr.dimension ||
2897 (sym->ts.type == BT_CHARACTER
2898 && sym->ts.u.cl->length
2899 && sym->ts.u.cl->length->expr_type
2904 formal = comp->formal;
2905 need_interface_mapping = comp->attr.dimension ||
2906 (comp->ts.type == BT_CHARACTER
2907 && comp->ts.u.cl->length
2908 && comp->ts.u.cl->length->expr_type
2912 /* Evaluate the arguments. */
2913 for (arg = args; arg != NULL;
2914 arg = arg->next, formal = formal ? formal->next : NULL)
2917 fsym = formal ? formal->sym : NULL;
2918 parm_kind = MISSING;
2922 if (se->ignore_optional)
2924 /* Some intrinsics have already been resolved to the correct
2928 else if (arg->label)
2930 has_alternate_specifier = 1;
2935 /* Pass a NULL pointer for an absent arg. */
2936 gfc_init_se (&parmse, NULL);
2937 parmse.expr = null_pointer_node;
2938 if (arg->missing_arg_type == BT_CHARACTER)
2939 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2942 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2944 /* Pass a NULL pointer to denote an absent arg. */
2945 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2946 gfc_init_se (&parmse, NULL);
2947 parmse.expr = null_pointer_node;
2948 if (arg->missing_arg_type == BT_CHARACTER)
2949 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2951 else if (fsym && fsym->ts.type == BT_CLASS
2952 && e->ts.type == BT_DERIVED)
2954 /* The derived type needs to be converted to a temporary
2956 gfc_init_se (&parmse, se);
2957 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2959 else if (se->ss && se->ss->useflags)
2961 /* An elemental function inside a scalarized loop. */
2962 gfc_init_se (&parmse, se);
2963 gfc_conv_expr_reference (&parmse, e);
2964 parm_kind = ELEMENTAL;
2968 /* A scalar or transformational function. */
2969 gfc_init_se (&parmse, NULL);
2970 argss = gfc_walk_expr (e);
2972 if (argss == gfc_ss_terminator)
2974 if (e->expr_type == EXPR_VARIABLE
2975 && e->symtree->n.sym->attr.cray_pointee
2976 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2978 /* The Cray pointer needs to be converted to a pointer to
2979 a type given by the expression. */
2980 gfc_conv_expr (&parmse, e);
2981 type = build_pointer_type (TREE_TYPE (parmse.expr));
2982 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2983 parmse.expr = convert (type, tmp);
2985 else if (fsym && fsym->attr.value)
2987 if (fsym->ts.type == BT_CHARACTER
2988 && fsym->ts.is_c_interop
2989 && fsym->ns->proc_name != NULL
2990 && fsym->ns->proc_name->attr.is_bind_c)
2993 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2994 if (parmse.expr == NULL)
2995 gfc_conv_expr (&parmse, e);
2998 gfc_conv_expr (&parmse, e);
3000 else if (arg->name && arg->name[0] == '%')
3001 /* Argument list functions %VAL, %LOC and %REF are signalled
3002 through arg->name. */
3003 conv_arglist_function (&parmse, arg->expr, arg->name);
3004 else if ((e->expr_type == EXPR_FUNCTION)
3005 && ((e->value.function.esym
3006 && e->value.function.esym->result->attr.pointer)
3007 || (!e->value.function.esym
3008 && e->symtree->n.sym->attr.pointer))
3009 && fsym && fsym->attr.target)
3011 gfc_conv_expr (&parmse, e);
3012 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3014 else if (e->expr_type == EXPR_FUNCTION
3015 && e->symtree->n.sym->result
3016 && e->symtree->n.sym->result != e->symtree->n.sym
3017 && e->symtree->n.sym->result->attr.proc_pointer)
3019 /* Functions returning procedure pointers. */
3020 gfc_conv_expr (&parmse, e);
3021 if (fsym && fsym->attr.proc_pointer)
3022 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3026 gfc_conv_expr_reference (&parmse, e);
3028 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3029 allocated on entry, it must be deallocated. */
3030 if (fsym && fsym->attr.allocatable
3031 && fsym->attr.intent == INTENT_OUT)
3035 gfc_init_block (&block);
3036 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3038 gfc_add_expr_to_block (&block, tmp);
3039 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3040 void_type_node, parmse.expr,
3042 gfc_add_expr_to_block (&block, tmp);
3044 if (fsym->attr.optional
3045 && e->expr_type == EXPR_VARIABLE
3046 && e->symtree->n.sym->attr.optional)
3048 tmp = fold_build3_loc (input_location, COND_EXPR,
3050 gfc_conv_expr_present (e->symtree->n.sym),
3051 gfc_finish_block (&block),
3052 build_empty_stmt (input_location));
3055 tmp = gfc_finish_block (&block);
3057 gfc_add_expr_to_block (&se->pre, tmp);
3060 if (fsym && e->expr_type != EXPR_NULL
3061 && ((fsym->attr.pointer
3062 && fsym->attr.flavor != FL_PROCEDURE)
3063 || (fsym->attr.proc_pointer
3064 && !(e->expr_type == EXPR_VARIABLE
3065 && e->symtree->n.sym->attr.dummy))
3066 || (fsym->attr.proc_pointer
3067 && e->expr_type == EXPR_VARIABLE
3068 && gfc_is_proc_ptr_comp (e, NULL))
3069 || fsym->attr.allocatable))
3071 /* Scalar pointer dummy args require an extra level of
3072 indirection. The null pointer already contains
3073 this level of indirection. */
3074 parm_kind = SCALAR_POINTER;
3075 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3081 /* If the procedure requires an explicit interface, the actual
3082 argument is passed according to the corresponding formal
3083 argument. If the corresponding formal argument is a POINTER,
3084 ALLOCATABLE or assumed shape, we do not use g77's calling
3085 convention, and pass the address of the array descriptor
3086 instead. Otherwise we use g77's calling convention. */
3089 && !(fsym->attr.pointer || fsym->attr.allocatable)
3090 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3092 f = f || !comp->attr.always_explicit;
3094 f = f || !sym->attr.always_explicit;
3096 /* If the argument is a function call that may not create
3097 a temporary for the result, we have to check that we
3098 can do it, i.e. that there is no alias between this
3099 argument and another one. */
3100 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3106 intent = fsym->attr.intent;
3108 intent = INTENT_UNKNOWN;
3110 if (gfc_check_fncall_dependency (e, intent, sym, args,
3112 parmse.force_tmp = 1;
3114 iarg = e->value.function.actual->expr;
3116 /* Temporary needed if aliasing due to host association. */
3117 if (sym->attr.contained
3119 && !sym->attr.implicit_pure
3120 && !sym->attr.use_assoc
3121 && iarg->expr_type == EXPR_VARIABLE
3122 && sym->ns == iarg->symtree->n.sym->ns)
3123 parmse.force_tmp = 1;
3125 /* Ditto within module. */
3126 if (sym->attr.use_assoc
3128 && !sym->attr.implicit_pure
3129 && iarg->expr_type == EXPR_VARIABLE
3130 && sym->module == iarg->symtree->n.sym->module)
3131 parmse.force_tmp = 1;
3134 if (e->expr_type == EXPR_VARIABLE
3135 && is_subref_array (e))
3136 /* The actual argument is a component reference to an
3137 array of derived types. In this case, the argument
3138 is converted to a temporary, which is passed and then
3139 written back after the procedure call. */
3140 gfc_conv_subref_array_arg (&parmse, e, f,
3141 fsym ? fsym->attr.intent : INTENT_INOUT,
3142 fsym && fsym->attr.pointer);
3144 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3147 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3148 allocated on entry, it must be deallocated. */
3149 if (fsym && fsym->attr.allocatable
3150 && fsym->attr.intent == INTENT_OUT)
3152 tmp = build_fold_indirect_ref_loc (input_location,
3154 tmp = gfc_trans_dealloc_allocated (tmp);
3155 if (fsym->attr.optional
3156 && e->expr_type == EXPR_VARIABLE
3157 && e->symtree->n.sym->attr.optional)
3158 tmp = fold_build3_loc (input_location, COND_EXPR,
3160 gfc_conv_expr_present (e->symtree->n.sym),
3161 tmp, build_empty_stmt (input_location));
3162 gfc_add_expr_to_block (&se->pre, tmp);
3167 /* The case with fsym->attr.optional is that of a user subroutine
3168 with an interface indicating an optional argument. When we call
3169 an intrinsic subroutine, however, fsym is NULL, but we might still
3170 have an optional argument, so we proceed to the substitution
3172 if (e && (fsym == NULL || fsym->attr.optional))
3174 /* If an optional argument is itself an optional dummy argument,
3175 check its presence and substitute a null if absent. This is
3176 only needed when passing an array to an elemental procedure
3177 as then array elements are accessed - or no NULL pointer is
3178 allowed and a "1" or "0" should be passed if not present.
3179 When passing a non-array-descriptor full array to a
3180 non-array-descriptor dummy, no check is needed. For
3181 array-descriptor actual to array-descriptor dummy, see
3182 PR 41911 for why a check has to be inserted.
3183 fsym == NULL is checked as intrinsics required the descriptor
3184 but do not always set fsym. */
3185 if (e->expr_type == EXPR_VARIABLE
3186 && e->symtree->n.sym->attr.optional
3187 && ((e->rank > 0 && sym->attr.elemental)
3188 || e->representation.length || e->ts.type == BT_CHARACTER
3192 && (fsym->as->type == AS_ASSUMED_SHAPE
3193 || fsym->as->type == AS_DEFERRED))))))
3194 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3195 e->representation.length);
3200 /* Obtain the character length of an assumed character length
3201 length procedure from the typespec. */
3202 if (fsym->ts.type == BT_CHARACTER
3203 && parmse.string_length == NULL_TREE
3204 && e->ts.type == BT_PROCEDURE
3205 && e->symtree->n.sym->ts.type == BT_CHARACTER
3206 && e->symtree->n.sym->ts.u.cl->length != NULL
3207 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3209 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3210 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3214 if (fsym && need_interface_mapping && e)
3215 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3217 gfc_add_block_to_block (&se->pre, &parmse.pre);
3218 gfc_add_block_to_block (&post, &parmse.post);
3220 /* Allocated allocatable components of derived types must be
3221 deallocated for non-variable scalars. Non-variable arrays are
3222 dealt with in trans-array.c(gfc_conv_array_parameter). */
3223 if (e && e->ts.type == BT_DERIVED
3224 && e->ts.u.derived->attr.alloc_comp
3225 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3226 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3229 tmp = build_fold_indirect_ref_loc (input_location,
3231 parm_rank = e->rank;
3239 case (SCALAR_POINTER):
3240 tmp = build_fold_indirect_ref_loc (input_location,
3245 if (e->expr_type == EXPR_OP
3246 && e->value.op.op == INTRINSIC_PARENTHESES
3247 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3250 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3251 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3252 gfc_add_expr_to_block (&se->post, local_tmp);
3255 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3257 gfc_add_expr_to_block (&se->post, tmp);
3260 /* Add argument checking of passing an unallocated/NULL actual to
3261 a nonallocatable/nonpointer dummy. */
3263 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3265 symbol_attribute attr;
3269 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3270 attr = gfc_expr_attr (e);
3272 goto end_pointer_check;
3274 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3275 allocatable to an optional dummy, cf. 12.5.2.12. */
3276 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3277 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3278 goto end_pointer_check;
3282 /* If the actual argument is an optional pointer/allocatable and
3283 the formal argument takes an nonpointer optional value,
3284 it is invalid to pass a non-present argument on, even
3285 though there is no technical reason for this in gfortran.
3286 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3287 tree present, null_ptr, type;
3289 if (attr.allocatable
3290 && (fsym == NULL || !fsym->attr.allocatable))
3291 asprintf (&msg, "Allocatable actual argument '%s' is not "
3292 "allocated or not present", e->symtree->n.sym->name);
3293 else if (attr.pointer
3294 && (fsym == NULL || !fsym->attr.pointer))
3295 asprintf (&msg, "Pointer actual argument '%s' is not "
3296 "associated or not present",
3297 e->symtree->n.sym->name);
3298 else if (attr.proc_pointer
3299 && (fsym == NULL || !fsym->attr.proc_pointer))
3300 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3301 "associated or not present",
3302 e->symtree->n.sym->name);
3304 goto end_pointer_check;
3306 present = gfc_conv_expr_present (e->symtree->n.sym);
3307 type = TREE_TYPE (present);
3308 present = fold_build2_loc (input_location, EQ_EXPR,
3309 boolean_type_node, present,
3311 null_pointer_node));
3312 type = TREE_TYPE (parmse.expr);
3313 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3314 boolean_type_node, parmse.expr,
3316 null_pointer_node));
3317 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3318 boolean_type_node, present, null_ptr);
3322 if (attr.allocatable
3323 && (fsym == NULL || !fsym->attr.allocatable))
3324 asprintf (&msg, "Allocatable actual argument '%s' is not "
3325 "allocated", e->symtree->n.sym->name);
3326 else if (attr.pointer
3327 && (fsym == NULL || !fsym->attr.pointer))
3328 asprintf (&msg, "Pointer actual argument '%s' is not "
3329 "associated", e->symtree->n.sym->name);
3330 else if (attr.proc_pointer
3331 && (fsym == NULL || !fsym->attr.proc_pointer))
3332 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3333 "associated", e->symtree->n.sym->name);
3335 goto end_pointer_check;
3338 cond = fold_build2_loc (input_location, EQ_EXPR,
3339 boolean_type_node, parmse.expr,
3340 fold_convert (TREE_TYPE (parmse.expr),
3341 null_pointer_node));
3344 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3350 /* Deferred length dummies pass the character length by reference
3351 so that the value can be returned. */
3352 if (parmse.string_length && fsym && fsym->ts.deferred)
3354 tmp = parmse.string_length;
3355 if (TREE_CODE (tmp) != VAR_DECL)
3356 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3357 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3360 /* Character strings are passed as two parameters, a length and a
3361 pointer - except for Bind(c) which only passes the pointer. */
3362 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3363 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3365 VEC_safe_push (tree, gc, arglist, parmse.expr);
3367 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3374 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3375 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3376 else if (ts.type == BT_CHARACTER)
3378 if (ts.u.cl->length == NULL)
3380 /* Assumed character length results are not allowed by 5.1.1.5 of the
3381 standard and are trapped in resolve.c; except in the case of SPREAD
3382 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3383 we take the character length of the first argument for the result.
3384 For dummies, we have to look through the formal argument list for
3385 this function and use the character length found there.*/
3386 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3387 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3388 else if (!sym->attr.dummy)
3389 cl.backend_decl = VEC_index (tree, stringargs, 0);
3392 formal = sym->ns->proc_name->formal;
3393 for (; formal; formal = formal->next)
3394 if (strcmp (formal->sym->name, sym->name) == 0)
3395 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3402 /* Calculate the length of the returned string. */
3403 gfc_init_se (&parmse, NULL);
3404 if (need_interface_mapping)
3405 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3407 gfc_conv_expr (&parmse, ts.u.cl->length);
3408 gfc_add_block_to_block (&se->pre, &parmse.pre);
3409 gfc_add_block_to_block (&se->post, &parmse.post);
3411 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3412 tmp = fold_build2_loc (input_location, MAX_EXPR,
3413 gfc_charlen_type_node, tmp,
3414 build_int_cst (gfc_charlen_type_node, 0));
3415 cl.backend_decl = tmp;
3418 /* Set up a charlen structure for it. */
3423 len = cl.backend_decl;
3426 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3427 || (!comp && gfc_return_by_reference (sym));
3430 if (se->direct_byref)
3432 /* Sometimes, too much indirection can be applied; e.g. for
3433 function_result = array_valued_recursive_function. */
3434 if (TREE_TYPE (TREE_TYPE (se->expr))
3435 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3436 && GFC_DESCRIPTOR_TYPE_P
3437 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3438 se->expr = build_fold_indirect_ref_loc (input_location,
3441 /* If the lhs of an assignment x = f(..) is allocatable and
3442 f2003 is allowed, we must do the automatic reallocation.
3443 TODO - deal with intrinsics, without using a temporary. */
3444 if (gfc_option.flag_realloc_lhs
3445 && se->ss && se->ss->loop_chain
3446 && se->ss->loop_chain->is_alloc_lhs
3447 && !expr->value.function.isym
3448 && sym->result->as != NULL)
3450 /* Evaluate the bounds of the result, if known. */
3451 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3454 /* Perform the automatic reallocation. */
3455 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3457 gfc_add_expr_to_block (&se->pre, tmp);
3459 /* Pass the temporary as the first argument. */
3460 result = info->descriptor;
3463 result = build_fold_indirect_ref_loc (input_location,
3465 VEC_safe_push (tree, gc, retargs, se->expr);
3467 else if (comp && comp->attr.dimension)
3469 gcc_assert (se->loop && info);
3471 /* Set the type of the array. */
3472 tmp = gfc_typenode_for_spec (&comp->ts);
3473 info->dimen = se->loop->dimen;
3475 /* Evaluate the bounds of the result, if known. */
3476 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3478 /* If the lhs of an assignment x = f(..) is allocatable and
3479 f2003 is allowed, we must not generate the function call
3480 here but should just send back the results of the mapping.
3481 This is signalled by the function ss being flagged. */
3482 if (gfc_option.flag_realloc_lhs
3483 && se->ss && se->ss->is_alloc_lhs)
3485 gfc_free_interface_mapping (&mapping);
3486 return has_alternate_specifier;
3489 /* Create a temporary to store the result. In case the function
3490 returns a pointer, the temporary will be a shallow copy and
3491 mustn't be deallocated. */
3492 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3493 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3494 NULL_TREE, false, !comp->attr.pointer,
3495 callee_alloc, &se->ss->expr->where);
3497 /* Pass the temporary as the first argument. */
3498 result = info->descriptor;
3499 tmp = gfc_build_addr_expr (NULL_TREE, result);
3500 VEC_safe_push (tree, gc, retargs, tmp);
3502 else if (!comp && sym->result->attr.dimension)
3504 gcc_assert (se->loop && info);
3506 /* Set the type of the array. */
3507 tmp = gfc_typenode_for_spec (&ts);
3508 info->dimen = se->loop->dimen;
3510 /* Evaluate the bounds of the result, if known. */
3511 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3513 /* If the lhs of an assignment x = f(..) is allocatable and
3514 f2003 is allowed, we must not generate the function call
3515 here but should just send back the results of the mapping.
3516 This is signalled by the function ss being flagged. */
3517 if (gfc_option.flag_realloc_lhs
3518 && se->ss && se->ss->is_alloc_lhs)
3520 gfc_free_interface_mapping (&mapping);
3521 return has_alternate_specifier;
3524 /* Create a temporary to store the result. In case the function
3525 returns a pointer, the temporary will be a shallow copy and
3526 mustn't be deallocated. */
3527 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3528 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3529 NULL_TREE, false, !sym->attr.pointer,
3530 callee_alloc, &se->ss->expr->where);
3532 /* Pass the temporary as the first argument. */
3533 result = info->descriptor;
3534 tmp = gfc_build_addr_expr (NULL_TREE, result);
3535 VEC_safe_push (tree, gc, retargs, tmp);
3537 else if (ts.type == BT_CHARACTER)
3539 /* Pass the string length. */
3540 type = gfc_get_character_type (ts.kind, ts.u.cl);
3541 type = build_pointer_type (type);
3543 /* Return an address to a char[0:len-1]* temporary for
3544 character pointers. */
3545 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3546 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3548 var = gfc_create_var (type, "pstr");
3550 if ((!comp && sym->attr.allocatable)
3551 || (comp && comp->attr.allocatable))
3552 gfc_add_modify (&se->pre, var,
3553 fold_convert (TREE_TYPE (var),
3554 null_pointer_node));
3556 /* Provide an address expression for the function arguments. */
3557 var = gfc_build_addr_expr (NULL_TREE, var);
3560 var = gfc_conv_string_tmp (se, type, len);
3562 VEC_safe_push (tree, gc, retargs, var);
3566 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3568 type = gfc_get_complex_type (ts.kind);
3569 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3570 VEC_safe_push (tree, gc, retargs, var);
3573 if (ts.type == BT_CHARACTER && ts.deferred
3574 && (sym->attr.allocatable || sym->attr.pointer))
3577 if (TREE_CODE (tmp) != VAR_DECL)
3578 tmp = gfc_evaluate_now (len, &se->pre);
3579 len = gfc_build_addr_expr (NULL_TREE, tmp);
3582 /* Add the string length to the argument list. */
3583 if (ts.type == BT_CHARACTER)
3584 VEC_safe_push (tree, gc, retargs, len);
3586 gfc_free_interface_mapping (&mapping);
3588 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3589 arglen = (VEC_length (tree, arglist)
3590 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3591 VEC_reserve_exact (tree, gc, retargs, arglen);
3593 /* Add the return arguments. */
3594 VEC_splice (tree, retargs, arglist);
3596 /* Add the hidden string length parameters to the arguments. */
3597 VEC_splice (tree, retargs, stringargs);
3599 /* We may want to append extra arguments here. This is used e.g. for
3600 calls to libgfortran_matmul_??, which need extra information. */
3601 if (!VEC_empty (tree, append_args))
3602 VEC_splice (tree, retargs, append_args);
3605 /* Generate the actual call. */
3606 conv_function_val (se, sym, expr);
3608 /* If there are alternate return labels, function type should be
3609 integer. Can't modify the type in place though, since it can be shared
3610 with other functions. For dummy arguments, the typing is done to
3611 this result, even if it has to be repeated for each call. */
3612 if (has_alternate_specifier
3613 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3615 if (!sym->attr.dummy)
3617 TREE_TYPE (sym->backend_decl)
3618 = build_function_type (integer_type_node,
3619 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3620 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3623 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3626 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3627 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3629 /* If we have a pointer function, but we don't want a pointer, e.g.
3632 where f is pointer valued, we have to dereference the result. */
3633 if (!se->want_pointer && !byref
3634 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3635 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3636 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3638 /* f2c calling conventions require a scalar default real function to
3639 return a double precision result. Convert this back to default
3640 real. We only care about the cases that can happen in Fortran 77.
3642 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3643 && sym->ts.kind == gfc_default_real_kind
3644 && !sym->attr.always_explicit)
3645 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3647 /* A pure function may still have side-effects - it may modify its
3649 TREE_SIDE_EFFECTS (se->expr) = 1;
3651 if (!sym->attr.pure)
3652 TREE_SIDE_EFFECTS (se->expr) = 1;
3657 /* Add the function call to the pre chain. There is no expression. */
3658 gfc_add_expr_to_block (&se->pre, se->expr);
3659 se->expr = NULL_TREE;
3661 if (!se->direct_byref)
3663 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3665 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3667 /* Check the data pointer hasn't been modified. This would
3668 happen in a function returning a pointer. */
3669 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3670 tmp = fold_build2_loc (input_location, NE_EXPR,
3673 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3676 se->expr = info->descriptor;
3677 /* Bundle in the string length. */
3678 se->string_length = len;
3680 else if (ts.type == BT_CHARACTER)
3682 /* Dereference for character pointer results. */
3683 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3684 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3685 se->expr = build_fold_indirect_ref_loc (input_location, var);
3690 se->string_length = len;
3691 else if (sym->attr.allocatable || sym->attr.pointer)
3692 se->string_length = cl.backend_decl;
3696 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3697 se->expr = build_fold_indirect_ref_loc (input_location, var);
3702 /* Follow the function call with the argument post block. */
3705 gfc_add_block_to_block (&se->pre, &post);
3707 /* Transformational functions of derived types with allocatable
3708 components must have the result allocatable components copied. */
3709 arg = expr->value.function.actual;
3710 if (result && arg && expr->rank
3711 && expr->value.function.isym
3712 && expr->value.function.isym->transformational
3713 && arg->expr->ts.type == BT_DERIVED
3714 && arg->expr->ts.u.derived->attr.alloc_comp)
3717 /* Copy the allocatable components. We have to use a
3718 temporary here to prevent source allocatable components
3719 from being corrupted. */
3720 tmp2 = gfc_evaluate_now (result, &se->pre);
3721 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3722 result, tmp2, expr->rank);
3723 gfc_add_expr_to_block (&se->pre, tmp);
3724 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3726 gfc_add_expr_to_block (&se->pre, tmp);
3728 /* Finally free the temporary's data field. */
3729 tmp = gfc_conv_descriptor_data_get (tmp2);
3730 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3731 gfc_add_expr_to_block (&se->pre, tmp);
3735 gfc_add_block_to_block (&se->post, &post);
3737 return has_alternate_specifier;
3741 /* Fill a character string with spaces. */
3744 fill_with_spaces (tree start, tree type, tree size)
3746 stmtblock_t block, loop;
3747 tree i, el, exit_label, cond, tmp;
3749 /* For a simple char type, we can call memset(). */
3750 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3751 return build_call_expr_loc (input_location,
3752 built_in_decls[BUILT_IN_MEMSET], 3, start,
3753 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3754 lang_hooks.to_target_charset (' ')),
3757 /* Otherwise, we use a loop:
3758 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3762 /* Initialize variables. */
3763 gfc_init_block (&block);
3764 i = gfc_create_var (sizetype, "i");
3765 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3766 el = gfc_create_var (build_pointer_type (type), "el");
3767 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3768 exit_label = gfc_build_label_decl (NULL_TREE);
3769 TREE_USED (exit_label) = 1;
3773 gfc_init_block (&loop);
3775 /* Exit condition. */
3776 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3777 build_zero_cst (sizetype));
3778 tmp = build1_v (GOTO_EXPR, exit_label);
3779 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3780 build_empty_stmt (input_location));
3781 gfc_add_expr_to_block (&loop, tmp);
3784 gfc_add_modify (&loop,
3785 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3786 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3788 /* Increment loop variables. */
3789 gfc_add_modify (&loop, i,
3790 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3791 TYPE_SIZE_UNIT (type)));
3792 gfc_add_modify (&loop, el,
3793 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3794 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3796 /* Making the loop... actually loop! */
3797 tmp = gfc_finish_block (&loop);
3798 tmp = build1_v (LOOP_EXPR, tmp);
3799 gfc_add_expr_to_block (&block, tmp);
3801 /* The exit label. */
3802 tmp = build1_v (LABEL_EXPR, exit_label);
3803 gfc_add_expr_to_block (&block, tmp);
3806 return gfc_finish_block (&block);
3810 /* Generate code to copy a string. */
3813 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3814 int dkind, tree slength, tree src, int skind)
3816 tree tmp, dlen, slen;
3825 stmtblock_t tempblock;
3827 gcc_assert (dkind == skind);
3829 if (slength != NULL_TREE)
3831 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3832 ssc = gfc_string_to_single_character (slen, src, skind);
3836 slen = build_int_cst (size_type_node, 1);
3840 if (dlength != NULL_TREE)
3842 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3843 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3847 dlen = build_int_cst (size_type_node, 1);
3851 /* Assign directly if the types are compatible. */
3852 if (dsc != NULL_TREE && ssc != NULL_TREE
3853 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3855 gfc_add_modify (block, dsc, ssc);
3859 /* Do nothing if the destination length is zero. */
3860 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3861 build_int_cst (size_type_node, 0));
3863 /* The following code was previously in _gfortran_copy_string:
3865 // The two strings may overlap so we use memmove.
3867 copy_string (GFC_INTEGER_4 destlen, char * dest,
3868 GFC_INTEGER_4 srclen, const char * src)
3870 if (srclen >= destlen)
3872 // This will truncate if too long.
3873 memmove (dest, src, destlen);
3877 memmove (dest, src, srclen);
3879 memset (&dest[srclen], ' ', destlen - srclen);
3883 We're now doing it here for better optimization, but the logic
3886 /* For non-default character kinds, we have to multiply the string
3887 length by the base type size. */
3888 chartype = gfc_get_char_type (dkind);
3889 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3890 fold_convert (size_type_node, slen),
3891 fold_convert (size_type_node,
3892 TYPE_SIZE_UNIT (chartype)));
3893 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3894 fold_convert (size_type_node, dlen),
3895 fold_convert (size_type_node,
3896 TYPE_SIZE_UNIT (chartype)));
3898 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3899 dest = fold_convert (pvoid_type_node, dest);
3901 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3903 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3904 src = fold_convert (pvoid_type_node, src);
3906 src = gfc_build_addr_expr (pvoid_type_node, src);
3908 /* Truncate string if source is too long. */
3909 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3911 tmp2 = build_call_expr_loc (input_location,
3912 built_in_decls[BUILT_IN_MEMMOVE],
3913 3, dest, src, dlen);
3915 /* Else copy and pad with spaces. */
3916 tmp3 = build_call_expr_loc (input_location,
3917 built_in_decls[BUILT_IN_MEMMOVE],
3918 3, dest, src, slen);
3920 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3921 dest, fold_convert (sizetype, slen));
3922 tmp4 = fill_with_spaces (tmp4, chartype,
3923 fold_build2_loc (input_location, MINUS_EXPR,
3924 TREE_TYPE(dlen), dlen, slen));
3926 gfc_init_block (&tempblock);
3927 gfc_add_expr_to_block (&tempblock, tmp3);
3928 gfc_add_expr_to_block (&tempblock, tmp4);
3929 tmp3 = gfc_finish_block (&tempblock);
3931 /* The whole copy_string function is there. */
3932 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3934 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3935 build_empty_stmt (input_location));
3936 gfc_add_expr_to_block (block, tmp);
3940 /* Translate a statement function.
3941 The value of a statement function reference is obtained by evaluating the
3942 expression using the values of the actual arguments for the values of the
3943 corresponding dummy arguments. */
3946 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3950 gfc_formal_arglist *fargs;
3951 gfc_actual_arglist *args;
3954 gfc_saved_var *saved_vars;
3960 sym = expr->symtree->n.sym;
3961 args = expr->value.function.actual;
3962 gfc_init_se (&lse, NULL);
3963 gfc_init_se (&rse, NULL);
3966 for (fargs = sym->formal; fargs; fargs = fargs->next)
3968 saved_vars = XCNEWVEC (gfc_saved_var, n);
3969 temp_vars = XCNEWVEC (tree, n);
3971 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3973 /* Each dummy shall be specified, explicitly or implicitly, to be
3975 gcc_assert (fargs->sym->attr.dimension == 0);
3978 if (fsym->ts.type == BT_CHARACTER)
3980 /* Copy string arguments. */
3983 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3984 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3986 /* Create a temporary to hold the value. */
3987 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3988 fsym->ts.u.cl->backend_decl
3989 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3991 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3992 temp_vars[n] = gfc_create_var (type, fsym->name);
3994 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3996 gfc_conv_expr (&rse, args->expr);
3997 gfc_conv_string_parameter (&rse);
3998 gfc_add_block_to_block (&se->pre, &lse.pre);
3999 gfc_add_block_to_block (&se->pre, &rse.pre);
4001 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4002 rse.string_length, rse.expr, fsym->ts.kind);
4003 gfc_add_block_to_block (&se->pre, &lse.post);
4004 gfc_add_block_to_block (&se->pre, &rse.post);
4008 /* For everything else, just evaluate the expression. */
4010 /* Create a temporary to hold the value. */
4011 type = gfc_typenode_for_spec (&fsym->ts);
4012 temp_vars[n] = gfc_create_var (type, fsym->name);
4014 gfc_conv_expr (&lse, args->expr);
4016 gfc_add_block_to_block (&se->pre, &lse.pre);
4017 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4018 gfc_add_block_to_block (&se->pre, &lse.post);
4024 /* Use the temporary variables in place of the real ones. */
4025 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4026 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4028 gfc_conv_expr (se, sym->value);
4030 if (sym->ts.type == BT_CHARACTER)
4032 gfc_conv_const_charlen (sym->ts.u.cl);
4034 /* Force the expression to the correct length. */
4035 if (!INTEGER_CST_P (se->string_length)
4036 || tree_int_cst_lt (se->string_length,
4037 sym->ts.u.cl->backend_decl))
4039 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4040 tmp = gfc_create_var (type, sym->name);
4041 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4042 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4043 sym->ts.kind, se->string_length, se->expr,
4047 se->string_length = sym->ts.u.cl->backend_decl;
4050 /* Restore the original variables. */
4051 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4052 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4057 /* Translate a function expression. */
4060 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4064 if (expr->value.function.isym)
4066 gfc_conv_intrinsic_function (se, expr);
4070 /* We distinguish statement functions from general functions to improve
4071 runtime performance. */
4072 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4074 gfc_conv_statement_function (se, expr);
4078 /* expr.value.function.esym is the resolved (specific) function symbol for
4079 most functions. However this isn't set for dummy procedures. */
4080 sym = expr->value.function.esym;
4082 sym = expr->symtree->n.sym;
4084 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4088 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4091 is_zero_initializer_p (gfc_expr * expr)
4093 if (expr->expr_type != EXPR_CONSTANT)
4096 /* We ignore constants with prescribed memory representations for now. */
4097 if (expr->representation.string)
4100 switch (expr->ts.type)
4103 return mpz_cmp_si (expr->value.integer, 0) == 0;
4106 return mpfr_zero_p (expr->value.real)
4107 && MPFR_SIGN (expr->value.real) >= 0;
4110 return expr->value.logical == 0;
4113 return mpfr_zero_p (mpc_realref (expr->value.complex))
4114 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4115 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4116 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4126 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4128 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4129 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4131 gfc_conv_tmp_array_ref (se);
4135 /* Build a static initializer. EXPR is the expression for the initial value.
4136 The other parameters describe the variable of the component being
4137 initialized. EXPR may be null. */
4140 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4141 bool array, bool pointer, bool procptr)
4145 if (!(expr || pointer || procptr))
4148 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4149 (these are the only two iso_c_binding derived types that can be
4150 used as initialization expressions). If so, we need to modify
4151 the 'expr' to be that for a (void *). */
4152 if (expr != NULL && expr->ts.type == BT_DERIVED
4153 && expr->ts.is_iso_c && expr->ts.u.derived)
4155 gfc_symbol *derived = expr->ts.u.derived;
4157 /* The derived symbol has already been converted to a (void *). Use
4159 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4160 expr->ts.f90_type = derived->ts.f90_type;
4162 gfc_init_se (&se, NULL);
4163 gfc_conv_constant (&se, expr);
4164 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4168 if (array && !procptr)
4171 /* Arrays need special handling. */
4173 ctor = gfc_build_null_descriptor (type);
4174 /* Special case assigning an array to zero. */
4175 else if (is_zero_initializer_p (expr))
4176 ctor = build_constructor (type, NULL);
4178 ctor = gfc_conv_array_initializer (type, expr);
4179 TREE_STATIC (ctor) = 1;
4182 else if (pointer || procptr)
4184 if (!expr || expr->expr_type == EXPR_NULL)
4185 return fold_convert (type, null_pointer_node);
4188 gfc_init_se (&se, NULL);
4189 se.want_pointer = 1;
4190 gfc_conv_expr (&se, expr);
4191 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4201 gfc_init_se (&se, NULL);
4202 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4203 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4205 gfc_conv_structure (&se, expr, 1);
4206 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4207 TREE_STATIC (se.expr) = 1;
4212 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4213 TREE_STATIC (ctor) = 1;
4218 gfc_init_se (&se, NULL);
4219 gfc_conv_constant (&se, expr);
4220 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4227 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4239 gfc_start_block (&block);
4241 /* Initialize the scalarizer. */
4242 gfc_init_loopinfo (&loop);
4244 gfc_init_se (&lse, NULL);
4245 gfc_init_se (&rse, NULL);
4248 rss = gfc_walk_expr (expr);
4249 if (rss == gfc_ss_terminator)
4251 /* The rhs is scalar. Add a ss for the expression. */
4252 rss = gfc_get_ss ();
4253 rss->next = gfc_ss_terminator;
4254 rss->type = GFC_SS_SCALAR;
4258 /* Create a SS for the destination. */
4259 lss = gfc_get_ss ();
4260 lss->type = GFC_SS_COMPONENT;
4262 lss->shape = gfc_get_shape (cm->as->rank);
4263 lss->next = gfc_ss_terminator;
4264 lss->data.info.dimen = cm->as->rank;
4265 lss->data.info.descriptor = dest;
4266 lss->data.info.data = gfc_conv_array_data (dest);
4267 lss->data.info.offset = gfc_conv_array_offset (dest);
4268 for (n = 0; n < cm->as->rank; n++)
4270 lss->data.info.dim[n] = n;
4271 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4272 lss->data.info.stride[n] = gfc_index_one_node;
4274 mpz_init (lss->shape[n]);
4275 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4276 cm->as->lower[n]->value.integer);
4277 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4280 /* Associate the SS with the loop. */
4281 gfc_add_ss_to_loop (&loop, lss);
4282 gfc_add_ss_to_loop (&loop, rss);
4284 /* Calculate the bounds of the scalarization. */
4285 gfc_conv_ss_startstride (&loop);
4287 /* Setup the scalarizing loops. */
4288 gfc_conv_loop_setup (&loop, &expr->where);
4290 /* Setup the gfc_se structures. */
4291 gfc_copy_loopinfo_to_se (&lse, &loop);
4292 gfc_copy_loopinfo_to_se (&rse, &loop);
4295 gfc_mark_ss_chain_used (rss, 1);
4297 gfc_mark_ss_chain_used (lss, 1);
4299 /* Start the scalarized loop body. */
4300 gfc_start_scalarized_body (&loop, &body);
4302 gfc_conv_tmp_array_ref (&lse);
4303 if (cm->ts.type == BT_CHARACTER)
4304 lse.string_length = cm->ts.u.cl->backend_decl;
4306 gfc_conv_expr (&rse, expr);
4308 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4309 gfc_add_expr_to_block (&body, tmp);
4311 gcc_assert (rse.ss == gfc_ss_terminator);
4313 /* Generate the copying loops. */
4314 gfc_trans_scalarizing_loops (&loop, &body);
4316 /* Wrap the whole thing up. */
4317 gfc_add_block_to_block (&block, &loop.pre);
4318 gfc_add_block_to_block (&block, &loop.post);
4320 for (n = 0; n < cm->as->rank; n++)
4321 mpz_clear (lss->shape[n]);
4324 gfc_cleanup_loop (&loop);
4326 return gfc_finish_block (&block);
4331 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4342 gfc_expr *arg = NULL;
4344 gfc_start_block (&block);
4345 gfc_init_se (&se, NULL);
4347 /* Get the descriptor for the expressions. */
4348 rss = gfc_walk_expr (expr);
4349 se.want_pointer = 0;
4350 gfc_conv_expr_descriptor (&se, expr, rss);
4351 gfc_add_block_to_block (&block, &se.pre);
4352 gfc_add_modify (&block, dest, se.expr);
4354 /* Deal with arrays of derived types with allocatable components. */
4355 if (cm->ts.type == BT_DERIVED
4356 && cm->ts.u.derived->attr.alloc_comp)
4357 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4361 tmp = gfc_duplicate_allocatable (dest, se.expr,
4362 TREE_TYPE(cm->backend_decl),
4365 gfc_add_expr_to_block (&block, tmp);
4366 gfc_add_block_to_block (&block, &se.post);
4368 if (expr->expr_type != EXPR_VARIABLE)
4369 gfc_conv_descriptor_data_set (&block, se.expr,
4372 /* We need to know if the argument of a conversion function is a
4373 variable, so that the correct lower bound can be used. */
4374 if (expr->expr_type == EXPR_FUNCTION
4375 && expr->value.function.isym
4376 && expr->value.function.isym->conversion
4377 && expr->value.function.actual->expr
4378 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4379 arg = expr->value.function.actual->expr;
4381 /* Obtain the array spec of full array references. */
4383 as = gfc_get_full_arrayspec_from_expr (arg);
4385 as = gfc_get_full_arrayspec_from_expr (expr);
4387 /* Shift the lbound and ubound of temporaries to being unity,
4388 rather than zero, based. Always calculate the offset. */
4389 offset = gfc_conv_descriptor_offset_get (dest);
4390 gfc_add_modify (&block, offset, gfc_index_zero_node);
4391 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4393 for (n = 0; n < expr->rank; n++)
4398 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4399 TODO It looks as if gfc_conv_expr_descriptor should return
4400 the correct bounds and that the following should not be
4401 necessary. This would simplify gfc_conv_intrinsic_bound
4403 if (as && as->lower[n])
4406 gfc_init_se (&lbse, NULL);
4407 gfc_conv_expr (&lbse, as->lower[n]);
4408 gfc_add_block_to_block (&block, &lbse.pre);
4409 lbound = gfc_evaluate_now (lbse.expr, &block);
4413 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4414 lbound = gfc_conv_descriptor_lbound_get (tmp,
4418 lbound = gfc_conv_descriptor_lbound_get (dest,
4421 lbound = gfc_index_one_node;
4423 lbound = fold_convert (gfc_array_index_type, lbound);
4425 /* Shift the bounds and set the offset accordingly. */
4426 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4427 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4428 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4429 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4431 gfc_conv_descriptor_ubound_set (&block, dest,
4432 gfc_rank_cst[n], tmp);
4433 gfc_conv_descriptor_lbound_set (&block, dest,
4434 gfc_rank_cst[n], lbound);
4436 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4437 gfc_conv_descriptor_lbound_get (dest,
4439 gfc_conv_descriptor_stride_get (dest,
4441 gfc_add_modify (&block, tmp2, tmp);
4442 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4444 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4449 /* If a conversion expression has a null data pointer
4450 argument, nullify the allocatable component. */
4454 if (arg->symtree->n.sym->attr.allocatable
4455 || arg->symtree->n.sym->attr.pointer)
4457 non_null_expr = gfc_finish_block (&block);
4458 gfc_start_block (&block);
4459 gfc_conv_descriptor_data_set (&block, dest,
4461 null_expr = gfc_finish_block (&block);
4462 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4463 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4464 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4465 return build3_v (COND_EXPR, tmp,
4466 null_expr, non_null_expr);
4470 return gfc_finish_block (&block);
4474 /* Assign a single component of a derived type constructor. */
4477 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4485 gfc_start_block (&block);
4487 if (cm->attr.pointer)
4489 gfc_init_se (&se, NULL);
4490 /* Pointer component. */
4491 if (cm->attr.dimension)
4493 /* Array pointer. */
4494 if (expr->expr_type == EXPR_NULL)
4495 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4498 rss = gfc_walk_expr (expr);
4499 se.direct_byref = 1;
4501 gfc_conv_expr_descriptor (&se, expr, rss);
4502 gfc_add_block_to_block (&block, &se.pre);
4503 gfc_add_block_to_block (&block, &se.post);
4508 /* Scalar pointers. */
4509 se.want_pointer = 1;
4510 gfc_conv_expr (&se, expr);
4511 gfc_add_block_to_block (&block, &se.pre);
4512 gfc_add_modify (&block, dest,
4513 fold_convert (TREE_TYPE (dest), se.expr));
4514 gfc_add_block_to_block (&block, &se.post);
4517 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4519 /* NULL initialization for CLASS components. */
4520 tmp = gfc_trans_structure_assign (dest,
4521 gfc_class_null_initializer (&cm->ts));
4522 gfc_add_expr_to_block (&block, tmp);
4524 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4526 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4527 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4528 else if (cm->attr.allocatable)
4530 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4531 gfc_add_expr_to_block (&block, tmp);
4535 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4536 gfc_add_expr_to_block (&block, tmp);
4539 else if (expr->ts.type == BT_DERIVED)
4541 if (expr->expr_type != EXPR_STRUCTURE)
4543 gfc_init_se (&se, NULL);
4544 gfc_conv_expr (&se, expr);
4545 gfc_add_block_to_block (&block, &se.pre);
4546 gfc_add_modify (&block, dest,
4547 fold_convert (TREE_TYPE (dest), se.expr));
4548 gfc_add_block_to_block (&block, &se.post);
4552 /* Nested constructors. */
4553 tmp = gfc_trans_structure_assign (dest, expr);
4554 gfc_add_expr_to_block (&block, tmp);
4559 /* Scalar component. */
4560 gfc_init_se (&se, NULL);
4561 gfc_init_se (&lse, NULL);
4563 gfc_conv_expr (&se, expr);
4564 if (cm->ts.type == BT_CHARACTER)
4565 lse.string_length = cm->ts.u.cl->backend_decl;
4567 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4568 gfc_add_expr_to_block (&block, tmp);
4570 return gfc_finish_block (&block);
4573 /* Assign a derived type constructor to a variable. */
4576 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4584 gfc_start_block (&block);
4585 cm = expr->ts.u.derived->components;
4587 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4588 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4589 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4593 gcc_assert (cm->backend_decl == NULL);
4594 gfc_init_se (&se, NULL);
4595 gfc_init_se (&lse, NULL);
4596 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4598 gfc_add_modify (&block, lse.expr,
4599 fold_convert (TREE_TYPE (lse.expr), se.expr));
4601 return gfc_finish_block (&block);
4604 for (c = gfc_constructor_first (expr->value.constructor);
4605 c; c = gfc_constructor_next (c), cm = cm->next)
4607 /* Skip absent members in default initializers. */
4611 field = cm->backend_decl;
4612 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4613 dest, field, NULL_TREE);
4614 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4615 gfc_add_expr_to_block (&block, tmp);
4617 return gfc_finish_block (&block);
4620 /* Build an expression for a constructor. If init is nonzero then
4621 this is part of a static variable initializer. */
4624 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4631 VEC(constructor_elt,gc) *v = NULL;
4633 gcc_assert (se->ss == NULL);
4634 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4635 type = gfc_typenode_for_spec (&expr->ts);
4639 /* Create a temporary variable and fill it in. */
4640 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4641 tmp = gfc_trans_structure_assign (se->expr, expr);
4642 gfc_add_expr_to_block (&se->pre, tmp);
4646 cm = expr->ts.u.derived->components;
4648 for (c = gfc_constructor_first (expr->value.constructor);
4649 c; c = gfc_constructor_next (c), cm = cm->next)
4651 /* Skip absent members in default initializers and allocatable
4652 components. Although the latter have a default initializer
4653 of EXPR_NULL,... by default, the static nullify is not needed
4654 since this is done every time we come into scope. */
4655 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4658 if (strcmp (cm->name, "_size") == 0)
4660 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4661 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4663 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4664 && strcmp (cm->name, "_extends") == 0)
4668 vtabs = cm->initializer->symtree->n.sym;
4669 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4670 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4674 val = gfc_conv_initializer (c->expr, &cm->ts,
4675 TREE_TYPE (cm->backend_decl),
4676 cm->attr.dimension, cm->attr.pointer,
4677 cm->attr.proc_pointer);
4679 /* Append it to the constructor list. */
4680 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4683 se->expr = build_constructor (type, v);
4685 TREE_CONSTANT (se->expr) = 1;
4689 /* Translate a substring expression. */
4692 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4698 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4700 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4701 expr->value.character.length,
4702 expr->value.character.string);
4704 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4705 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4708 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4712 /* Entry point for expression translation. Evaluates a scalar quantity.
4713 EXPR is the expression to be translated, and SE is the state structure if
4714 called from within the scalarized. */
4717 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4719 if (se->ss && se->ss->expr == expr
4720 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4722 /* Substitute a scalar expression evaluated outside the scalarization
4724 se->expr = se->ss->data.scalar.expr;
4725 if (se->ss->type == GFC_SS_REFERENCE)
4726 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4727 se->string_length = se->ss->string_length;
4728 gfc_advance_se_ss_chain (se);
4732 /* We need to convert the expressions for the iso_c_binding derived types.
4733 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4734 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4735 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4736 updated to be an integer with a kind equal to the size of a (void *). */
4737 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4738 && expr->ts.u.derived->attr.is_iso_c)
4740 if (expr->expr_type == EXPR_VARIABLE
4741 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4742 || expr->symtree->n.sym->intmod_sym_id
4743 == ISOCBINDING_NULL_FUNPTR))
4745 /* Set expr_type to EXPR_NULL, which will result in
4746 null_pointer_node being used below. */
4747 expr->expr_type = EXPR_NULL;
4751 /* Update the type/kind of the expression to be what the new
4752 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4753 expr->ts.type = expr->ts.u.derived->ts.type;
4754 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4755 expr->ts.kind = expr->ts.u.derived->ts.kind;
4759 switch (expr->expr_type)
4762 gfc_conv_expr_op (se, expr);
4766 gfc_conv_function_expr (se, expr);
4770 gfc_conv_constant (se, expr);
4774 gfc_conv_variable (se, expr);
4778 se->expr = null_pointer_node;
4781 case EXPR_SUBSTRING:
4782 gfc_conv_substring_expr (se, expr);
4785 case EXPR_STRUCTURE:
4786 gfc_conv_structure (se, expr, 0);
4790 gfc_conv_array_constructor_expr (se, expr);
4799 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4800 of an assignment. */
4802 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4804 gfc_conv_expr (se, expr);
4805 /* All numeric lvalues should have empty post chains. If not we need to
4806 figure out a way of rewriting an lvalue so that it has no post chain. */
4807 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4810 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4811 numeric expressions. Used for scalar values where inserting cleanup code
4814 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4818 gcc_assert (expr->ts.type != BT_CHARACTER);
4819 gfc_conv_expr (se, expr);
4822 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4823 gfc_add_modify (&se->pre, val, se->expr);
4825 gfc_add_block_to_block (&se->pre, &se->post);
4829 /* Helper to translate an expression and convert it to a particular type. */
4831 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4833 gfc_conv_expr_val (se, expr);
4834 se->expr = convert (type, se->expr);
4838 /* Converts an expression so that it can be passed by reference. Scalar
4842 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4846 if (se->ss && se->ss->expr == expr
4847 && se->ss->type == GFC_SS_REFERENCE)
4849 /* Returns a reference to the scalar evaluated outside the loop
4851 gfc_conv_expr (se, expr);
4855 if (expr->ts.type == BT_CHARACTER)
4857 gfc_conv_expr (se, expr);
4858 gfc_conv_string_parameter (se);
4862 if (expr->expr_type == EXPR_VARIABLE)
4864 se->want_pointer = 1;
4865 gfc_conv_expr (se, expr);
4868 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4869 gfc_add_modify (&se->pre, var, se->expr);
4870 gfc_add_block_to_block (&se->pre, &se->post);
4876 if (expr->expr_type == EXPR_FUNCTION
4877 && ((expr->value.function.esym
4878 && expr->value.function.esym->result->attr.pointer
4879 && !expr->value.function.esym->result->attr.dimension)
4880 || (!expr->value.function.esym
4881 && expr->symtree->n.sym->attr.pointer
4882 && !expr->symtree->n.sym->attr.dimension)))
4884 se->want_pointer = 1;
4885 gfc_conv_expr (se, expr);
4886 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4887 gfc_add_modify (&se->pre, var, se->expr);
4893 gfc_conv_expr (se, expr);
4895 /* Create a temporary var to hold the value. */
4896 if (TREE_CONSTANT (se->expr))
4898 tree tmp = se->expr;
4899 STRIP_TYPE_NOPS (tmp);
4900 var = build_decl (input_location,
4901 CONST_DECL, NULL, TREE_TYPE (tmp));
4902 DECL_INITIAL (var) = tmp;
4903 TREE_STATIC (var) = 1;
4908 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4909 gfc_add_modify (&se->pre, var, se->expr);
4911 gfc_add_block_to_block (&se->pre, &se->post);
4913 /* Take the address of that value. */
4914 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4919 gfc_trans_pointer_assign (gfc_code * code)
4921 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4925 /* Generate code for a pointer assignment. */
4928 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4939 gfc_start_block (&block);
4941 gfc_init_se (&lse, NULL);
4943 lss = gfc_walk_expr (expr1);
4944 rss = gfc_walk_expr (expr2);
4945 if (lss == gfc_ss_terminator)
4947 /* Scalar pointers. */
4948 lse.want_pointer = 1;
4949 gfc_conv_expr (&lse, expr1);
4950 gcc_assert (rss == gfc_ss_terminator);
4951 gfc_init_se (&rse, NULL);
4952 rse.want_pointer = 1;
4953 gfc_conv_expr (&rse, expr2);
4955 if (expr1->symtree->n.sym->attr.proc_pointer
4956 && expr1->symtree->n.sym->attr.dummy)
4957 lse.expr = build_fold_indirect_ref_loc (input_location,
4960 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4961 && expr2->symtree->n.sym->attr.dummy)
4962 rse.expr = build_fold_indirect_ref_loc (input_location,
4965 gfc_add_block_to_block (&block, &lse.pre);
4966 gfc_add_block_to_block (&block, &rse.pre);
4968 /* Check character lengths if character expression. The test is only
4969 really added if -fbounds-check is enabled. Exclude deferred
4970 character length lefthand sides. */
4971 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4972 && !(expr1->ts.deferred
4973 && (TREE_CODE (lse.string_length) == VAR_DECL))
4974 && !expr1->symtree->n.sym->attr.proc_pointer
4975 && !gfc_is_proc_ptr_comp (expr1, NULL))
4977 gcc_assert (expr2->ts.type == BT_CHARACTER);
4978 gcc_assert (lse.string_length && rse.string_length);
4979 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4980 lse.string_length, rse.string_length,
4984 /* The assignment to an deferred character length sets the string
4985 length to that of the rhs. */
4986 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4988 if (expr2->expr_type != EXPR_NULL)
4989 gfc_add_modify (&block, lse.string_length, rse.string_length);
4991 gfc_add_modify (&block, lse.string_length,
4992 build_int_cst (gfc_charlen_type_node, 0));
4995 gfc_add_modify (&block, lse.expr,
4996 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4998 gfc_add_block_to_block (&block, &rse.post);
4999 gfc_add_block_to_block (&block, &lse.post);
5006 tree strlen_rhs = NULL_TREE;
5008 /* Array pointer. Find the last reference on the LHS and if it is an
5009 array section ref, we're dealing with bounds remapping. In this case,
5010 set it to AR_FULL so that gfc_conv_expr_descriptor does
5011 not see it and process the bounds remapping afterwards explicitely. */
5012 for (remap = expr1->ref; remap; remap = remap->next)
5013 if (!remap->next && remap->type == REF_ARRAY
5014 && remap->u.ar.type == AR_SECTION)
5016 remap->u.ar.type = AR_FULL;
5019 rank_remap = (remap && remap->u.ar.end[0]);
5021 gfc_conv_expr_descriptor (&lse, expr1, lss);
5022 strlen_lhs = lse.string_length;
5025 if (expr2->expr_type == EXPR_NULL)
5027 /* Just set the data pointer to null. */
5028 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5030 else if (rank_remap)
5032 /* If we are rank-remapping, just get the RHS's descriptor and
5033 process this later on. */
5034 gfc_init_se (&rse, NULL);
5035 rse.direct_byref = 1;
5036 rse.byref_noassign = 1;
5037 gfc_conv_expr_descriptor (&rse, expr2, rss);
5038 strlen_rhs = rse.string_length;
5040 else if (expr2->expr_type == EXPR_VARIABLE)
5042 /* Assign directly to the LHS's descriptor. */
5043 lse.direct_byref = 1;
5044 gfc_conv_expr_descriptor (&lse, expr2, rss);
5045 strlen_rhs = lse.string_length;
5047 /* If this is a subreference array pointer assignment, use the rhs
5048 descriptor element size for the lhs span. */
5049 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5051 decl = expr1->symtree->n.sym->backend_decl;
5052 gfc_init_se (&rse, NULL);
5053 rse.descriptor_only = 1;
5054 gfc_conv_expr (&rse, expr2);
5055 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5056 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5057 if (!INTEGER_CST_P (tmp))
5058 gfc_add_block_to_block (&lse.post, &rse.pre);
5059 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5064 /* Assign to a temporary descriptor and then copy that
5065 temporary to the pointer. */
5066 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5069 lse.direct_byref = 1;
5070 gfc_conv_expr_descriptor (&lse, expr2, rss);
5071 strlen_rhs = lse.string_length;
5072 gfc_add_modify (&lse.pre, desc, tmp);
5075 gfc_add_block_to_block (&block, &lse.pre);
5077 gfc_add_block_to_block (&block, &rse.pre);
5079 /* If we do bounds remapping, update LHS descriptor accordingly. */
5083 gcc_assert (remap->u.ar.dimen == expr1->rank);
5087 /* Do rank remapping. We already have the RHS's descriptor
5088 converted in rse and now have to build the correct LHS
5089 descriptor for it. */
5093 tree lbound, ubound;
5096 dtype = gfc_conv_descriptor_dtype (desc);
5097 tmp = gfc_get_dtype (TREE_TYPE (desc));
5098 gfc_add_modify (&block, dtype, tmp);
5100 /* Copy data pointer. */
5101 data = gfc_conv_descriptor_data_get (rse.expr);
5102 gfc_conv_descriptor_data_set (&block, desc, data);
5104 /* Copy offset but adjust it such that it would correspond
5105 to a lbound of zero. */
5106 offs = gfc_conv_descriptor_offset_get (rse.expr);
5107 for (dim = 0; dim < expr2->rank; ++dim)
5109 stride = gfc_conv_descriptor_stride_get (rse.expr,
5111 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5113 tmp = fold_build2_loc (input_location, MULT_EXPR,
5114 gfc_array_index_type, stride, lbound);
5115 offs = fold_build2_loc (input_location, PLUS_EXPR,
5116 gfc_array_index_type, offs, tmp);
5118 gfc_conv_descriptor_offset_set (&block, desc, offs);
5120 /* Set the bounds as declared for the LHS and calculate strides as
5121 well as another offset update accordingly. */
5122 stride = gfc_conv_descriptor_stride_get (rse.expr,
5124 for (dim = 0; dim < expr1->rank; ++dim)
5129 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5131 /* Convert declared bounds. */
5132 gfc_init_se (&lower_se, NULL);
5133 gfc_init_se (&upper_se, NULL);
5134 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5135 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5137 gfc_add_block_to_block (&block, &lower_se.pre);
5138 gfc_add_block_to_block (&block, &upper_se.pre);
5140 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5141 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5143 lbound = gfc_evaluate_now (lbound, &block);
5144 ubound = gfc_evaluate_now (ubound, &block);
5146 gfc_add_block_to_block (&block, &lower_se.post);
5147 gfc_add_block_to_block (&block, &upper_se.post);
5149 /* Set bounds in descriptor. */
5150 gfc_conv_descriptor_lbound_set (&block, desc,
5151 gfc_rank_cst[dim], lbound);
5152 gfc_conv_descriptor_ubound_set (&block, desc,
5153 gfc_rank_cst[dim], ubound);
5156 stride = gfc_evaluate_now (stride, &block);
5157 gfc_conv_descriptor_stride_set (&block, desc,
5158 gfc_rank_cst[dim], stride);
5160 /* Update offset. */
5161 offs = gfc_conv_descriptor_offset_get (desc);
5162 tmp = fold_build2_loc (input_location, MULT_EXPR,
5163 gfc_array_index_type, lbound, stride);
5164 offs = fold_build2_loc (input_location, MINUS_EXPR,
5165 gfc_array_index_type, offs, tmp);
5166 offs = gfc_evaluate_now (offs, &block);
5167 gfc_conv_descriptor_offset_set (&block, desc, offs);
5169 /* Update stride. */
5170 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5171 stride = fold_build2_loc (input_location, MULT_EXPR,
5172 gfc_array_index_type, stride, tmp);
5177 /* Bounds remapping. Just shift the lower bounds. */
5179 gcc_assert (expr1->rank == expr2->rank);
5181 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5185 gcc_assert (remap->u.ar.start[dim]);
5186 gcc_assert (!remap->u.ar.end[dim]);
5187 gfc_init_se (&lbound_se, NULL);
5188 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5190 gfc_add_block_to_block (&block, &lbound_se.pre);
5191 gfc_conv_shift_descriptor_lbound (&block, desc,
5192 dim, lbound_se.expr);
5193 gfc_add_block_to_block (&block, &lbound_se.post);
5198 /* Check string lengths if applicable. The check is only really added
5199 to the output code if -fbounds-check is enabled. */
5200 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5202 gcc_assert (expr2->ts.type == BT_CHARACTER);
5203 gcc_assert (strlen_lhs && strlen_rhs);
5204 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5205 strlen_lhs, strlen_rhs, &block);
5208 /* If rank remapping was done, check with -fcheck=bounds that
5209 the target is at least as large as the pointer. */
5210 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5216 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5217 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5219 lsize = gfc_evaluate_now (lsize, &block);
5220 rsize = gfc_evaluate_now (rsize, &block);
5221 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5224 msg = _("Target of rank remapping is too small (%ld < %ld)");
5225 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5229 gfc_add_block_to_block (&block, &lse.post);
5231 gfc_add_block_to_block (&block, &rse.post);
5234 return gfc_finish_block (&block);
5238 /* Makes sure se is suitable for passing as a function string parameter. */
5239 /* TODO: Need to check all callers of this function. It may be abused. */
5242 gfc_conv_string_parameter (gfc_se * se)
5246 if (TREE_CODE (se->expr) == STRING_CST)
5248 type = TREE_TYPE (TREE_TYPE (se->expr));
5249 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5253 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5255 if (TREE_CODE (se->expr) != INDIRECT_REF)
5257 type = TREE_TYPE (se->expr);
5258 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5262 type = gfc_get_character_type_len (gfc_default_character_kind,
5264 type = build_pointer_type (type);
5265 se->expr = gfc_build_addr_expr (type, se->expr);
5269 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5273 /* Generate code for assignment of scalar variables. Includes character
5274 strings and derived types with allocatable components.
5275 If you know that the LHS has no allocations, set dealloc to false. */
5278 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5279 bool l_is_temp, bool r_is_var, bool dealloc)
5285 gfc_init_block (&block);
5287 if (ts.type == BT_CHARACTER)
5292 if (lse->string_length != NULL_TREE)
5294 gfc_conv_string_parameter (lse);
5295 gfc_add_block_to_block (&block, &lse->pre);
5296 llen = lse->string_length;
5299 if (rse->string_length != NULL_TREE)
5301 gcc_assert (rse->string_length != NULL_TREE);
5302 gfc_conv_string_parameter (rse);
5303 gfc_add_block_to_block (&block, &rse->pre);
5304 rlen = rse->string_length;
5307 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5308 rse->expr, ts.kind);
5310 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5314 /* Are the rhs and the lhs the same? */
5317 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5318 gfc_build_addr_expr (NULL_TREE, lse->expr),
5319 gfc_build_addr_expr (NULL_TREE, rse->expr));
5320 cond = gfc_evaluate_now (cond, &lse->pre);
5323 /* Deallocate the lhs allocated components as long as it is not
5324 the same as the rhs. This must be done following the assignment
5325 to prevent deallocating data that could be used in the rhs
5327 if (!l_is_temp && dealloc)
5329 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5330 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5332 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5334 gfc_add_expr_to_block (&lse->post, tmp);
5337 gfc_add_block_to_block (&block, &rse->pre);
5338 gfc_add_block_to_block (&block, &lse->pre);
5340 gfc_add_modify (&block, lse->expr,
5341 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5343 /* Do a deep copy if the rhs is a variable, if it is not the
5347 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5348 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5350 gfc_add_expr_to_block (&block, tmp);
5353 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5355 gfc_add_block_to_block (&block, &lse->pre);
5356 gfc_add_block_to_block (&block, &rse->pre);
5357 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5358 TREE_TYPE (lse->expr), rse->expr);
5359 gfc_add_modify (&block, lse->expr, tmp);
5363 gfc_add_block_to_block (&block, &lse->pre);
5364 gfc_add_block_to_block (&block, &rse->pre);
5366 gfc_add_modify (&block, lse->expr,
5367 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5370 gfc_add_block_to_block (&block, &lse->post);
5371 gfc_add_block_to_block (&block, &rse->post);
5373 return gfc_finish_block (&block);
5377 /* There are quite a lot of restrictions on the optimisation in using an
5378 array function assign without a temporary. */
5381 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5384 bool seen_array_ref;
5386 gfc_symbol *sym = expr1->symtree->n.sym;
5388 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5389 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5392 /* Elemental functions are scalarized so that they don't need a
5393 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5394 they would need special treatment in gfc_trans_arrayfunc_assign. */
5395 if (expr2->value.function.esym != NULL
5396 && expr2->value.function.esym->attr.elemental)
5399 /* Need a temporary if rhs is not FULL or a contiguous section. */
5400 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5403 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5404 if (gfc_ref_needs_temporary_p (expr1->ref))
5407 /* Functions returning pointers or allocatables need temporaries. */
5408 c = expr2->value.function.esym
5409 ? (expr2->value.function.esym->attr.pointer
5410 || expr2->value.function.esym->attr.allocatable)
5411 : (expr2->symtree->n.sym->attr.pointer
5412 || expr2->symtree->n.sym->attr.allocatable);
5416 /* Character array functions need temporaries unless the
5417 character lengths are the same. */
5418 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5420 if (expr1->ts.u.cl->length == NULL
5421 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5424 if (expr2->ts.u.cl->length == NULL
5425 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5428 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5429 expr2->ts.u.cl->length->value.integer) != 0)
5433 /* Check that no LHS component references appear during an array
5434 reference. This is needed because we do not have the means to
5435 span any arbitrary stride with an array descriptor. This check
5436 is not needed for the rhs because the function result has to be
5438 seen_array_ref = false;
5439 for (ref = expr1->ref; ref; ref = ref->next)
5441 if (ref->type == REF_ARRAY)
5442 seen_array_ref= true;
5443 else if (ref->type == REF_COMPONENT && seen_array_ref)
5447 /* Check for a dependency. */
5448 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5449 expr2->value.function.esym,
5450 expr2->value.function.actual,
5454 /* If we have reached here with an intrinsic function, we do not
5455 need a temporary except in the particular case that reallocation
5456 on assignment is active and the lhs is allocatable and a target. */
5457 if (expr2->value.function.isym)
5458 return (gfc_option.flag_realloc_lhs
5459 && sym->attr.allocatable
5460 && sym->attr.target);
5462 /* If the LHS is a dummy, we need a temporary if it is not
5464 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5467 /* If the lhs has been host_associated, is in common, a pointer or is
5468 a target and the function is not using a RESULT variable, aliasing
5469 can occur and a temporary is needed. */
5470 if ((sym->attr.host_assoc
5471 || sym->attr.in_common
5472 || sym->attr.pointer
5473 || sym->attr.cray_pointee
5474 || sym->attr.target)
5475 && expr2->symtree != NULL
5476 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5479 /* A PURE function can unconditionally be called without a temporary. */
5480 if (expr2->value.function.esym != NULL
5481 && expr2->value.function.esym->attr.pure)
5484 /* Implicit_pure functions are those which could legally be declared
5486 if (expr2->value.function.esym != NULL
5487 && expr2->value.function.esym->attr.implicit_pure)
5490 if (!sym->attr.use_assoc
5491 && !sym->attr.in_common
5492 && !sym->attr.pointer
5493 && !sym->attr.target
5494 && !sym->attr.cray_pointee
5495 && expr2->value.function.esym)
5497 /* A temporary is not needed if the function is not contained and
5498 the variable is local or host associated and not a pointer or
5500 if (!expr2->value.function.esym->attr.contained)
5503 /* A temporary is not needed if the lhs has never been host
5504 associated and the procedure is contained. */
5505 else if (!sym->attr.host_assoc)
5508 /* A temporary is not needed if the variable is local and not
5509 a pointer, a target or a result. */
5511 && expr2->value.function.esym->ns == sym->ns->parent)
5515 /* Default to temporary use. */
5520 /* Provide the loop info so that the lhs descriptor can be built for
5521 reallocatable assignments from extrinsic function calls. */
5524 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5527 /* Signal that the function call should not be made by
5528 gfc_conv_loop_setup. */
5529 se->ss->is_alloc_lhs = 1;
5530 gfc_init_loopinfo (loop);
5531 gfc_add_ss_to_loop (loop, *ss);
5532 gfc_add_ss_to_loop (loop, se->ss);
5533 gfc_conv_ss_startstride (loop);
5534 gfc_conv_loop_setup (loop, where);
5535 gfc_copy_loopinfo_to_se (se, loop);
5536 gfc_add_block_to_block (&se->pre, &loop->pre);
5537 gfc_add_block_to_block (&se->pre, &loop->post);
5538 se->ss->is_alloc_lhs = 0;
5542 /* For Assignment to a reallocatable lhs from intrinsic functions,
5543 replace the se.expr (ie. the result) with a temporary descriptor.
5544 Null the data field so that the library allocates space for the
5545 result. Free the data of the original descriptor after the function,
5546 in case it appears in an argument expression and transfer the
5547 result to the original descriptor. */
5550 fcncall_realloc_result (gfc_se *se, int rank)
5558 /* Use the allocation done by the library. Substitute the lhs
5559 descriptor with a copy, whose data field is nulled.*/
5560 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5561 /* Unallocated, the descriptor does not have a dtype. */
5562 tmp = gfc_conv_descriptor_dtype (desc);
5563 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5564 res_desc = gfc_evaluate_now (desc, &se->pre);
5565 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5566 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5568 /* Free the lhs after the function call and copy the result to
5569 the lhs descriptor. */
5570 tmp = gfc_conv_descriptor_data_get (desc);
5571 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5572 gfc_add_expr_to_block (&se->post, tmp);
5573 gfc_add_modify (&se->post, desc, res_desc);
5575 offset = gfc_index_zero_node;
5576 tmp = gfc_index_one_node;
5577 /* Now reset the bounds from zero based to unity based. */
5578 for (n = 0 ; n < rank; n++)
5580 /* Accumulate the offset. */
5581 offset = fold_build2_loc (input_location, MINUS_EXPR,
5582 gfc_array_index_type,
5584 /* Now do the bounds. */
5585 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5586 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5587 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5588 gfc_array_index_type,
5589 tmp, gfc_index_one_node);
5590 gfc_conv_descriptor_lbound_set (&se->post, desc,
5592 gfc_index_one_node);
5593 gfc_conv_descriptor_ubound_set (&se->post, desc,
5594 gfc_rank_cst[n], tmp);
5596 /* The extent for the next contribution to offset. */
5597 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5598 gfc_array_index_type,
5599 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5600 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5601 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5602 gfc_array_index_type,
5603 tmp, gfc_index_one_node);
5605 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5610 /* Try to translate array(:) = func (...), where func is a transformational
5611 array function, without using a temporary. Returns NULL if this isn't the
5615 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5619 gfc_component *comp = NULL;
5622 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5625 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5627 gcc_assert (expr2->value.function.isym
5628 || (gfc_is_proc_ptr_comp (expr2, &comp)
5629 && comp && comp->attr.dimension)
5630 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5631 && expr2->value.function.esym->result->attr.dimension));
5633 ss = gfc_walk_expr (expr1);
5634 gcc_assert (ss != gfc_ss_terminator);
5635 gfc_init_se (&se, NULL);
5636 gfc_start_block (&se.pre);
5637 se.want_pointer = 1;
5639 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5641 if (expr1->ts.type == BT_DERIVED
5642 && expr1->ts.u.derived->attr.alloc_comp)
5645 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5647 gfc_add_expr_to_block (&se.pre, tmp);
5650 se.direct_byref = 1;
5651 se.ss = gfc_walk_expr (expr2);
5652 gcc_assert (se.ss != gfc_ss_terminator);
5654 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5655 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5656 Clearly, this cannot be done for an allocatable function result, since
5657 the shape of the result is unknown and, in any case, the function must
5658 correctly take care of the reallocation internally. For intrinsic
5659 calls, the array data is freed and the library takes care of allocation.
5660 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5662 if (gfc_option.flag_realloc_lhs
5663 && gfc_is_reallocatable_lhs (expr1)
5664 && !gfc_expr_attr (expr1).codimension
5665 && !gfc_is_coindexed (expr1)
5666 && !(expr2->value.function.esym
5667 && expr2->value.function.esym->result->attr.allocatable))
5669 if (!expr2->value.function.isym)
5671 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5672 ss->is_alloc_lhs = 1;
5675 fcncall_realloc_result (&se, expr1->rank);
5678 gfc_conv_function_expr (&se, expr2);
5679 gfc_add_block_to_block (&se.pre, &se.post);
5681 return gfc_finish_block (&se.pre);
5685 /* Try to efficiently translate array(:) = 0. Return NULL if this
5689 gfc_trans_zero_assign (gfc_expr * expr)
5691 tree dest, len, type;
5695 sym = expr->symtree->n.sym;
5696 dest = gfc_get_symbol_decl (sym);
5698 type = TREE_TYPE (dest);
5699 if (POINTER_TYPE_P (type))
5700 type = TREE_TYPE (type);
5701 if (!GFC_ARRAY_TYPE_P (type))
5704 /* Determine the length of the array. */
5705 len = GFC_TYPE_ARRAY_SIZE (type);
5706 if (!len || TREE_CODE (len) != INTEGER_CST)
5709 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5710 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5711 fold_convert (gfc_array_index_type, tmp));
5713 /* If we are zeroing a local array avoid taking its address by emitting
5715 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5716 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5717 dest, build_constructor (TREE_TYPE (dest), NULL));
5719 /* Convert arguments to the correct types. */
5720 dest = fold_convert (pvoid_type_node, dest);
5721 len = fold_convert (size_type_node, len);
5723 /* Construct call to __builtin_memset. */
5724 tmp = build_call_expr_loc (input_location,
5725 built_in_decls[BUILT_IN_MEMSET],
5726 3, dest, integer_zero_node, len);
5727 return fold_convert (void_type_node, tmp);
5731 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5732 that constructs the call to __builtin_memcpy. */
5735 gfc_build_memcpy_call (tree dst, tree src, tree len)
5739 /* Convert arguments to the correct types. */
5740 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5741 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5743 dst = fold_convert (pvoid_type_node, dst);
5745 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5746 src = gfc_build_addr_expr (pvoid_type_node, src);
5748 src = fold_convert (pvoid_type_node, src);
5750 len = fold_convert (size_type_node, len);
5752 /* Construct call to __builtin_memcpy. */
5753 tmp = build_call_expr_loc (input_location,
5754 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5755 return fold_convert (void_type_node, tmp);
5759 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5760 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5761 source/rhs, both are gfc_full_array_ref_p which have been checked for
5765 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5767 tree dst, dlen, dtype;
5768 tree src, slen, stype;
5771 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5772 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5774 dtype = TREE_TYPE (dst);
5775 if (POINTER_TYPE_P (dtype))
5776 dtype = TREE_TYPE (dtype);
5777 stype = TREE_TYPE (src);
5778 if (POINTER_TYPE_P (stype))
5779 stype = TREE_TYPE (stype);
5781 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5784 /* Determine the lengths of the arrays. */
5785 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5786 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5788 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5789 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5790 dlen, fold_convert (gfc_array_index_type, tmp));
5792 slen = GFC_TYPE_ARRAY_SIZE (stype);
5793 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5795 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5796 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5797 slen, fold_convert (gfc_array_index_type, tmp));
5799 /* Sanity check that they are the same. This should always be
5800 the case, as we should already have checked for conformance. */
5801 if (!tree_int_cst_equal (slen, dlen))
5804 return gfc_build_memcpy_call (dst, src, dlen);
5808 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5809 this can't be done. EXPR1 is the destination/lhs for which
5810 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5813 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5815 unsigned HOST_WIDE_INT nelem;
5821 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5825 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5826 dtype = TREE_TYPE (dst);
5827 if (POINTER_TYPE_P (dtype))
5828 dtype = TREE_TYPE (dtype);
5829 if (!GFC_ARRAY_TYPE_P (dtype))
5832 /* Determine the lengths of the array. */
5833 len = GFC_TYPE_ARRAY_SIZE (dtype);
5834 if (!len || TREE_CODE (len) != INTEGER_CST)
5837 /* Confirm that the constructor is the same size. */
5838 if (compare_tree_int (len, nelem) != 0)
5841 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5842 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5843 fold_convert (gfc_array_index_type, tmp));
5845 stype = gfc_typenode_for_spec (&expr2->ts);
5846 src = gfc_build_constant_array_constructor (expr2, stype);
5848 stype = TREE_TYPE (src);
5849 if (POINTER_TYPE_P (stype))
5850 stype = TREE_TYPE (stype);
5852 return gfc_build_memcpy_call (dst, src, len);
5856 /* Tells whether the expression is to be treated as a variable reference. */
5859 expr_is_variable (gfc_expr *expr)
5863 if (expr->expr_type == EXPR_VARIABLE)
5866 arg = gfc_get_noncopying_intrinsic_argument (expr);
5869 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5870 return expr_is_variable (arg);
5877 /* Is the lhs OK for automatic reallocation? */
5880 is_scalar_reallocatable_lhs (gfc_expr *expr)
5884 /* An allocatable variable with no reference. */
5885 if (expr->symtree->n.sym->attr.allocatable
5889 /* All that can be left are allocatable components. */
5890 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5891 && expr->symtree->n.sym->ts.type != BT_CLASS)
5892 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5895 /* Find an allocatable component ref last. */
5896 for (ref = expr->ref; ref; ref = ref->next)
5897 if (ref->type == REF_COMPONENT
5899 && ref->u.c.component->attr.allocatable)
5906 /* Allocate or reallocate scalar lhs, as necessary. */
5909 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5923 if (!expr1 || expr1->rank)
5926 if (!expr2 || expr2->rank)
5929 /* Since this is a scalar lhs, we can afford to do this. That is,
5930 there is no risk of side effects being repeated. */
5931 gfc_init_se (&lse, NULL);
5932 lse.want_pointer = 1;
5933 gfc_conv_expr (&lse, expr1);
5935 jump_label1 = gfc_build_label_decl (NULL_TREE);
5936 jump_label2 = gfc_build_label_decl (NULL_TREE);
5938 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5939 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5940 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5942 tmp = build3_v (COND_EXPR, cond,
5943 build1_v (GOTO_EXPR, jump_label1),
5944 build_empty_stmt (input_location));
5945 gfc_add_expr_to_block (block, tmp);
5947 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5949 /* Use the rhs string length and the lhs element size. */
5950 size = string_length;
5951 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5952 tmp = TYPE_SIZE_UNIT (tmp);
5953 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5954 TREE_TYPE (tmp), tmp,
5955 fold_convert (TREE_TYPE (tmp), size));
5959 /* Otherwise use the length in bytes of the rhs. */
5960 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5961 size_in_bytes = size;
5964 tmp = build_call_expr_loc (input_location,
5965 built_in_decls[BUILT_IN_MALLOC], 1,
5967 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5968 gfc_add_modify (block, lse.expr, tmp);
5969 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5971 /* Deferred characters need checking for lhs and rhs string
5972 length. Other deferred parameter variables will have to
5974 tmp = build1_v (GOTO_EXPR, jump_label2);
5975 gfc_add_expr_to_block (block, tmp);
5977 tmp = build1_v (LABEL_EXPR, jump_label1);
5978 gfc_add_expr_to_block (block, tmp);
5980 /* For a deferred length character, reallocate if lengths of lhs and
5981 rhs are different. */
5982 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5984 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5985 expr1->ts.u.cl->backend_decl, size);
5986 /* Jump past the realloc if the lengths are the same. */
5987 tmp = build3_v (COND_EXPR, cond,
5988 build1_v (GOTO_EXPR, jump_label2),
5989 build_empty_stmt (input_location));
5990 gfc_add_expr_to_block (block, tmp);
5991 tmp = build_call_expr_loc (input_location,
5992 built_in_decls[BUILT_IN_REALLOC], 2,
5993 fold_convert (pvoid_type_node, lse.expr),
5995 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5996 gfc_add_modify (block, lse.expr, tmp);
5997 tmp = build1_v (LABEL_EXPR, jump_label2);
5998 gfc_add_expr_to_block (block, tmp);
6000 /* Update the lhs character length. */
6001 size = string_length;
6002 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6007 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6008 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6009 init_flag indicates initialization expressions and dealloc that no
6010 deallocate prior assignment is needed (if in doubt, set true). */
6013 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6019 gfc_ss *lss_section;
6026 bool scalar_to_array;
6031 /* Assignment of the form lhs = rhs. */
6032 gfc_start_block (&block);
6034 gfc_init_se (&lse, NULL);
6035 gfc_init_se (&rse, NULL);
6038 lss = gfc_walk_expr (expr1);
6039 if (gfc_is_reallocatable_lhs (expr1)
6040 && !(expr2->expr_type == EXPR_FUNCTION
6041 && expr2->value.function.isym != NULL))
6042 lss->is_alloc_lhs = 1;
6044 if (lss != gfc_ss_terminator)
6046 /* Allow the scalarizer to workshare array assignments. */
6047 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6048 ompws_flags |= OMPWS_SCALARIZER_WS;
6050 /* The assignment needs scalarization. */
6053 /* Find a non-scalar SS from the lhs. */
6054 while (lss_section != gfc_ss_terminator
6055 && lss_section->type != GFC_SS_SECTION)
6056 lss_section = lss_section->next;
6058 gcc_assert (lss_section != gfc_ss_terminator);
6060 /* Initialize the scalarizer. */
6061 gfc_init_loopinfo (&loop);
6064 rss = gfc_walk_expr (expr2);
6065 if (rss == gfc_ss_terminator)
6067 /* The rhs is scalar. Add a ss for the expression. */
6068 rss = gfc_get_ss ();
6069 rss->next = gfc_ss_terminator;
6070 rss->type = GFC_SS_SCALAR;
6073 /* Associate the SS with the loop. */
6074 gfc_add_ss_to_loop (&loop, lss);
6075 gfc_add_ss_to_loop (&loop, rss);
6077 /* Calculate the bounds of the scalarization. */
6078 gfc_conv_ss_startstride (&loop);
6079 /* Enable loop reversal. */
6080 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6081 loop.reverse[n] = GFC_ENABLE_REVERSE;
6082 /* Resolve any data dependencies in the statement. */
6083 gfc_conv_resolve_dependencies (&loop, lss, rss);
6084 /* Setup the scalarizing loops. */
6085 gfc_conv_loop_setup (&loop, &expr2->where);
6087 /* Setup the gfc_se structures. */
6088 gfc_copy_loopinfo_to_se (&lse, &loop);
6089 gfc_copy_loopinfo_to_se (&rse, &loop);
6092 gfc_mark_ss_chain_used (rss, 1);
6093 if (loop.temp_ss == NULL)
6096 gfc_mark_ss_chain_used (lss, 1);
6100 lse.ss = loop.temp_ss;
6101 gfc_mark_ss_chain_used (lss, 3);
6102 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6105 /* Start the scalarized loop body. */
6106 gfc_start_scalarized_body (&loop, &body);
6109 gfc_init_block (&body);
6111 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6113 /* Translate the expression. */
6114 gfc_conv_expr (&rse, expr2);
6116 /* Stabilize a string length for temporaries. */
6117 if (expr2->ts.type == BT_CHARACTER)
6118 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6120 string_length = NULL_TREE;
6124 gfc_conv_tmp_array_ref (&lse);
6125 if (expr2->ts.type == BT_CHARACTER)
6126 lse.string_length = string_length;
6129 gfc_conv_expr (&lse, expr1);
6131 /* Assignments of scalar derived types with allocatable components
6132 to arrays must be done with a deep copy and the rhs temporary
6133 must have its components deallocated afterwards. */
6134 scalar_to_array = (expr2->ts.type == BT_DERIVED
6135 && expr2->ts.u.derived->attr.alloc_comp
6136 && !expr_is_variable (expr2)
6137 && !gfc_is_constant_expr (expr2)
6138 && expr1->rank && !expr2->rank);
6139 if (scalar_to_array && dealloc)
6141 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6142 gfc_add_expr_to_block (&loop.post, tmp);
6145 /* For a deferred character length function, the function call must
6146 happen before the (re)allocation of the lhs, otherwise the character
6147 length of the result is not known. */
6148 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6149 || (expr2->expr_type == EXPR_COMPCALL)
6150 || (expr2->expr_type == EXPR_PPC))
6151 && expr2->ts.deferred);
6152 if (gfc_option.flag_realloc_lhs
6153 && expr2->ts.type == BT_CHARACTER
6154 && (def_clen_func || expr2->expr_type == EXPR_OP)
6155 && expr1->ts.deferred)
6156 gfc_add_block_to_block (&block, &rse.pre);
6158 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6159 l_is_temp || init_flag,
6160 expr_is_variable (expr2) || scalar_to_array
6161 || expr2->expr_type == EXPR_ARRAY, dealloc);
6162 gfc_add_expr_to_block (&body, tmp);
6164 if (lss == gfc_ss_terminator)
6166 /* F2003: Add the code for reallocation on assignment. */
6167 if (gfc_option.flag_realloc_lhs
6168 && is_scalar_reallocatable_lhs (expr1))
6169 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6172 /* Use the scalar assignment as is. */
6173 gfc_add_block_to_block (&block, &body);
6177 gcc_assert (lse.ss == gfc_ss_terminator
6178 && rse.ss == gfc_ss_terminator);
6182 gfc_trans_scalarized_loop_boundary (&loop, &body);
6184 /* We need to copy the temporary to the actual lhs. */
6185 gfc_init_se (&lse, NULL);
6186 gfc_init_se (&rse, NULL);
6187 gfc_copy_loopinfo_to_se (&lse, &loop);
6188 gfc_copy_loopinfo_to_se (&rse, &loop);
6190 rse.ss = loop.temp_ss;
6193 gfc_conv_tmp_array_ref (&rse);
6194 gfc_conv_expr (&lse, expr1);
6196 gcc_assert (lse.ss == gfc_ss_terminator
6197 && rse.ss == gfc_ss_terminator);
6199 if (expr2->ts.type == BT_CHARACTER)
6200 rse.string_length = string_length;
6202 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6203 false, false, dealloc);
6204 gfc_add_expr_to_block (&body, tmp);
6207 /* F2003: Allocate or reallocate lhs of allocatable array. */
6208 if (gfc_option.flag_realloc_lhs
6209 && gfc_is_reallocatable_lhs (expr1)
6210 && !gfc_expr_attr (expr1).codimension
6211 && !gfc_is_coindexed (expr1))
6213 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6214 if (tmp != NULL_TREE)
6215 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6218 /* Generate the copying loops. */
6219 gfc_trans_scalarizing_loops (&loop, &body);
6221 /* Wrap the whole thing up. */
6222 gfc_add_block_to_block (&block, &loop.pre);
6223 gfc_add_block_to_block (&block, &loop.post);
6225 gfc_cleanup_loop (&loop);
6228 return gfc_finish_block (&block);
6232 /* Check whether EXPR is a copyable array. */
6235 copyable_array_p (gfc_expr * expr)
6237 if (expr->expr_type != EXPR_VARIABLE)
6240 /* First check it's an array. */
6241 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6244 if (!gfc_full_array_ref_p (expr->ref, NULL))
6247 /* Next check that it's of a simple enough type. */
6248 switch (expr->ts.type)
6260 return !expr->ts.u.derived->attr.alloc_comp;
6269 /* Translate an assignment. */
6272 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6277 /* Special case a single function returning an array. */
6278 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6280 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6285 /* Special case assigning an array to zero. */
6286 if (copyable_array_p (expr1)
6287 && is_zero_initializer_p (expr2))
6289 tmp = gfc_trans_zero_assign (expr1);
6294 /* Special case copying one array to another. */
6295 if (copyable_array_p (expr1)
6296 && copyable_array_p (expr2)
6297 && gfc_compare_types (&expr1->ts, &expr2->ts)
6298 && !gfc_check_dependency (expr1, expr2, 0))
6300 tmp = gfc_trans_array_copy (expr1, expr2);
6305 /* Special case initializing an array from a constant array constructor. */
6306 if (copyable_array_p (expr1)
6307 && expr2->expr_type == EXPR_ARRAY
6308 && gfc_compare_types (&expr1->ts, &expr2->ts))
6310 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6315 /* Fallback to the scalarizer to generate explicit loops. */
6316 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6320 gfc_trans_init_assign (gfc_code * code)
6322 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6326 gfc_trans_assign (gfc_code * code)
6328 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6332 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6333 A MEMCPY is needed to copy the full data from the default initializer
6334 of the dynamic type. */
6337 gfc_trans_class_init_assign (gfc_code *code)
6341 gfc_se dst,src,memsz;
6342 gfc_expr *lhs,*rhs,*sz;
6344 gfc_start_block (&block);
6346 lhs = gfc_copy_expr (code->expr1);
6347 gfc_add_data_component (lhs);
6349 rhs = gfc_copy_expr (code->expr1);
6350 gfc_add_vptr_component (rhs);
6352 /* Make sure that the component backend_decls have been built, which
6353 will not have happened if the derived types concerned have not
6355 gfc_get_derived_type (rhs->ts.u.derived);
6356 gfc_add_def_init_component (rhs);
6358 sz = gfc_copy_expr (code->expr1);
6359 gfc_add_vptr_component (sz);
6360 gfc_add_size_component (sz);
6362 gfc_init_se (&dst, NULL);
6363 gfc_init_se (&src, NULL);
6364 gfc_init_se (&memsz, NULL);
6365 gfc_conv_expr (&dst, lhs);
6366 gfc_conv_expr (&src, rhs);
6367 gfc_conv_expr (&memsz, sz);
6368 gfc_add_block_to_block (&block, &src.pre);
6369 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6370 gfc_add_expr_to_block (&block, tmp);
6372 return gfc_finish_block (&block);
6376 /* Translate an assignment to a CLASS object
6377 (pointer or ordinary assignment). */
6380 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6387 gfc_start_block (&block);
6389 if (expr2->ts.type != BT_CLASS)
6391 /* Insert an additional assignment which sets the '_vptr' field. */
6392 gfc_symbol *vtab = NULL;
6395 lhs = gfc_copy_expr (expr1);
6396 gfc_add_vptr_component (lhs);
6398 if (expr2->ts.type == BT_DERIVED)
6399 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6400 else if (expr2->expr_type == EXPR_NULL)
6401 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6404 rhs = gfc_get_expr ();
6405 rhs->expr_type = EXPR_VARIABLE;
6406 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6410 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6411 gfc_add_expr_to_block (&block, tmp);
6413 gfc_free_expr (lhs);
6414 gfc_free_expr (rhs);
6417 /* Do the actual CLASS assignment. */
6418 if (expr2->ts.type == BT_CLASS)
6421 gfc_add_data_component (expr1);
6423 if (op == EXEC_ASSIGN)
6424 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6425 else if (op == EXEC_POINTER_ASSIGN)
6426 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6430 gfc_add_expr_to_block (&block, tmp);
6432 return gfc_finish_block (&block);