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_build_pointer_plus_loc (input_location,
3794 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_build_pointer_plus_loc (input_location, dest, slen);
3921 tmp4 = fill_with_spaces (tmp4, chartype,
3922 fold_build2_loc (input_location, MINUS_EXPR,
3923 TREE_TYPE(dlen), dlen, slen));
3925 gfc_init_block (&tempblock);
3926 gfc_add_expr_to_block (&tempblock, tmp3);
3927 gfc_add_expr_to_block (&tempblock, tmp4);
3928 tmp3 = gfc_finish_block (&tempblock);
3930 /* The whole copy_string function is there. */
3931 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3933 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3934 build_empty_stmt (input_location));
3935 gfc_add_expr_to_block (block, tmp);
3939 /* Translate a statement function.
3940 The value of a statement function reference is obtained by evaluating the
3941 expression using the values of the actual arguments for the values of the
3942 corresponding dummy arguments. */
3945 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3949 gfc_formal_arglist *fargs;
3950 gfc_actual_arglist *args;
3953 gfc_saved_var *saved_vars;
3959 sym = expr->symtree->n.sym;
3960 args = expr->value.function.actual;
3961 gfc_init_se (&lse, NULL);
3962 gfc_init_se (&rse, NULL);
3965 for (fargs = sym->formal; fargs; fargs = fargs->next)
3967 saved_vars = XCNEWVEC (gfc_saved_var, n);
3968 temp_vars = XCNEWVEC (tree, n);
3970 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3972 /* Each dummy shall be specified, explicitly or implicitly, to be
3974 gcc_assert (fargs->sym->attr.dimension == 0);
3977 if (fsym->ts.type == BT_CHARACTER)
3979 /* Copy string arguments. */
3982 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3983 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3985 /* Create a temporary to hold the value. */
3986 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3987 fsym->ts.u.cl->backend_decl
3988 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3990 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3991 temp_vars[n] = gfc_create_var (type, fsym->name);
3993 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3995 gfc_conv_expr (&rse, args->expr);
3996 gfc_conv_string_parameter (&rse);
3997 gfc_add_block_to_block (&se->pre, &lse.pre);
3998 gfc_add_block_to_block (&se->pre, &rse.pre);
4000 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4001 rse.string_length, rse.expr, fsym->ts.kind);
4002 gfc_add_block_to_block (&se->pre, &lse.post);
4003 gfc_add_block_to_block (&se->pre, &rse.post);
4007 /* For everything else, just evaluate the expression. */
4009 /* Create a temporary to hold the value. */
4010 type = gfc_typenode_for_spec (&fsym->ts);
4011 temp_vars[n] = gfc_create_var (type, fsym->name);
4013 gfc_conv_expr (&lse, args->expr);
4015 gfc_add_block_to_block (&se->pre, &lse.pre);
4016 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4017 gfc_add_block_to_block (&se->pre, &lse.post);
4023 /* Use the temporary variables in place of the real ones. */
4024 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4025 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4027 gfc_conv_expr (se, sym->value);
4029 if (sym->ts.type == BT_CHARACTER)
4031 gfc_conv_const_charlen (sym->ts.u.cl);
4033 /* Force the expression to the correct length. */
4034 if (!INTEGER_CST_P (se->string_length)
4035 || tree_int_cst_lt (se->string_length,
4036 sym->ts.u.cl->backend_decl))
4038 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4039 tmp = gfc_create_var (type, sym->name);
4040 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4041 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4042 sym->ts.kind, se->string_length, se->expr,
4046 se->string_length = sym->ts.u.cl->backend_decl;
4049 /* Restore the original variables. */
4050 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4051 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4056 /* Translate a function expression. */
4059 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4063 if (expr->value.function.isym)
4065 gfc_conv_intrinsic_function (se, expr);
4069 /* We distinguish statement functions from general functions to improve
4070 runtime performance. */
4071 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4073 gfc_conv_statement_function (se, expr);
4077 /* expr.value.function.esym is the resolved (specific) function symbol for
4078 most functions. However this isn't set for dummy procedures. */
4079 sym = expr->value.function.esym;
4081 sym = expr->symtree->n.sym;
4083 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4087 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4090 is_zero_initializer_p (gfc_expr * expr)
4092 if (expr->expr_type != EXPR_CONSTANT)
4095 /* We ignore constants with prescribed memory representations for now. */
4096 if (expr->representation.string)
4099 switch (expr->ts.type)
4102 return mpz_cmp_si (expr->value.integer, 0) == 0;
4105 return mpfr_zero_p (expr->value.real)
4106 && MPFR_SIGN (expr->value.real) >= 0;
4109 return expr->value.logical == 0;
4112 return mpfr_zero_p (mpc_realref (expr->value.complex))
4113 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4114 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4115 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4125 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4127 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4128 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4130 gfc_conv_tmp_array_ref (se);
4134 /* Build a static initializer. EXPR is the expression for the initial value.
4135 The other parameters describe the variable of the component being
4136 initialized. EXPR may be null. */
4139 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4140 bool array, bool pointer, bool procptr)
4144 if (!(expr || pointer || procptr))
4147 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4148 (these are the only two iso_c_binding derived types that can be
4149 used as initialization expressions). If so, we need to modify
4150 the 'expr' to be that for a (void *). */
4151 if (expr != NULL && expr->ts.type == BT_DERIVED
4152 && expr->ts.is_iso_c && expr->ts.u.derived)
4154 gfc_symbol *derived = expr->ts.u.derived;
4156 /* The derived symbol has already been converted to a (void *). Use
4158 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4159 expr->ts.f90_type = derived->ts.f90_type;
4161 gfc_init_se (&se, NULL);
4162 gfc_conv_constant (&se, expr);
4163 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4167 if (array && !procptr)
4170 /* Arrays need special handling. */
4172 ctor = gfc_build_null_descriptor (type);
4173 /* Special case assigning an array to zero. */
4174 else if (is_zero_initializer_p (expr))
4175 ctor = build_constructor (type, NULL);
4177 ctor = gfc_conv_array_initializer (type, expr);
4178 TREE_STATIC (ctor) = 1;
4181 else if (pointer || procptr)
4183 if (!expr || expr->expr_type == EXPR_NULL)
4184 return fold_convert (type, null_pointer_node);
4187 gfc_init_se (&se, NULL);
4188 se.want_pointer = 1;
4189 gfc_conv_expr (&se, expr);
4190 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4200 gfc_init_se (&se, NULL);
4201 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4202 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4204 gfc_conv_structure (&se, expr, 1);
4205 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4206 TREE_STATIC (se.expr) = 1;
4211 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4212 TREE_STATIC (ctor) = 1;
4217 gfc_init_se (&se, NULL);
4218 gfc_conv_constant (&se, expr);
4219 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4226 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4238 gfc_start_block (&block);
4240 /* Initialize the scalarizer. */
4241 gfc_init_loopinfo (&loop);
4243 gfc_init_se (&lse, NULL);
4244 gfc_init_se (&rse, NULL);
4247 rss = gfc_walk_expr (expr);
4248 if (rss == gfc_ss_terminator)
4250 /* The rhs is scalar. Add a ss for the expression. */
4251 rss = gfc_get_ss ();
4252 rss->next = gfc_ss_terminator;
4253 rss->type = GFC_SS_SCALAR;
4257 /* Create a SS for the destination. */
4258 lss = gfc_get_ss ();
4259 lss->type = GFC_SS_COMPONENT;
4261 lss->shape = gfc_get_shape (cm->as->rank);
4262 lss->next = gfc_ss_terminator;
4263 lss->data.info.dimen = cm->as->rank;
4264 lss->data.info.descriptor = dest;
4265 lss->data.info.data = gfc_conv_array_data (dest);
4266 lss->data.info.offset = gfc_conv_array_offset (dest);
4267 for (n = 0; n < cm->as->rank; n++)
4269 lss->data.info.dim[n] = n;
4270 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4271 lss->data.info.stride[n] = gfc_index_one_node;
4273 mpz_init (lss->shape[n]);
4274 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4275 cm->as->lower[n]->value.integer);
4276 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4279 /* Associate the SS with the loop. */
4280 gfc_add_ss_to_loop (&loop, lss);
4281 gfc_add_ss_to_loop (&loop, rss);
4283 /* Calculate the bounds of the scalarization. */
4284 gfc_conv_ss_startstride (&loop);
4286 /* Setup the scalarizing loops. */
4287 gfc_conv_loop_setup (&loop, &expr->where);
4289 /* Setup the gfc_se structures. */
4290 gfc_copy_loopinfo_to_se (&lse, &loop);
4291 gfc_copy_loopinfo_to_se (&rse, &loop);
4294 gfc_mark_ss_chain_used (rss, 1);
4296 gfc_mark_ss_chain_used (lss, 1);
4298 /* Start the scalarized loop body. */
4299 gfc_start_scalarized_body (&loop, &body);
4301 gfc_conv_tmp_array_ref (&lse);
4302 if (cm->ts.type == BT_CHARACTER)
4303 lse.string_length = cm->ts.u.cl->backend_decl;
4305 gfc_conv_expr (&rse, expr);
4307 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4308 gfc_add_expr_to_block (&body, tmp);
4310 gcc_assert (rse.ss == gfc_ss_terminator);
4312 /* Generate the copying loops. */
4313 gfc_trans_scalarizing_loops (&loop, &body);
4315 /* Wrap the whole thing up. */
4316 gfc_add_block_to_block (&block, &loop.pre);
4317 gfc_add_block_to_block (&block, &loop.post);
4319 for (n = 0; n < cm->as->rank; n++)
4320 mpz_clear (lss->shape[n]);
4323 gfc_cleanup_loop (&loop);
4325 return gfc_finish_block (&block);
4330 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4341 gfc_expr *arg = NULL;
4343 gfc_start_block (&block);
4344 gfc_init_se (&se, NULL);
4346 /* Get the descriptor for the expressions. */
4347 rss = gfc_walk_expr (expr);
4348 se.want_pointer = 0;
4349 gfc_conv_expr_descriptor (&se, expr, rss);
4350 gfc_add_block_to_block (&block, &se.pre);
4351 gfc_add_modify (&block, dest, se.expr);
4353 /* Deal with arrays of derived types with allocatable components. */
4354 if (cm->ts.type == BT_DERIVED
4355 && cm->ts.u.derived->attr.alloc_comp)
4356 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4360 tmp = gfc_duplicate_allocatable (dest, se.expr,
4361 TREE_TYPE(cm->backend_decl),
4364 gfc_add_expr_to_block (&block, tmp);
4365 gfc_add_block_to_block (&block, &se.post);
4367 if (expr->expr_type != EXPR_VARIABLE)
4368 gfc_conv_descriptor_data_set (&block, se.expr,
4371 /* We need to know if the argument of a conversion function is a
4372 variable, so that the correct lower bound can be used. */
4373 if (expr->expr_type == EXPR_FUNCTION
4374 && expr->value.function.isym
4375 && expr->value.function.isym->conversion
4376 && expr->value.function.actual->expr
4377 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4378 arg = expr->value.function.actual->expr;
4380 /* Obtain the array spec of full array references. */
4382 as = gfc_get_full_arrayspec_from_expr (arg);
4384 as = gfc_get_full_arrayspec_from_expr (expr);
4386 /* Shift the lbound and ubound of temporaries to being unity,
4387 rather than zero, based. Always calculate the offset. */
4388 offset = gfc_conv_descriptor_offset_get (dest);
4389 gfc_add_modify (&block, offset, gfc_index_zero_node);
4390 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4392 for (n = 0; n < expr->rank; n++)
4397 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4398 TODO It looks as if gfc_conv_expr_descriptor should return
4399 the correct bounds and that the following should not be
4400 necessary. This would simplify gfc_conv_intrinsic_bound
4402 if (as && as->lower[n])
4405 gfc_init_se (&lbse, NULL);
4406 gfc_conv_expr (&lbse, as->lower[n]);
4407 gfc_add_block_to_block (&block, &lbse.pre);
4408 lbound = gfc_evaluate_now (lbse.expr, &block);
4412 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4413 lbound = gfc_conv_descriptor_lbound_get (tmp,
4417 lbound = gfc_conv_descriptor_lbound_get (dest,
4420 lbound = gfc_index_one_node;
4422 lbound = fold_convert (gfc_array_index_type, lbound);
4424 /* Shift the bounds and set the offset accordingly. */
4425 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4426 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4427 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4428 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4430 gfc_conv_descriptor_ubound_set (&block, dest,
4431 gfc_rank_cst[n], tmp);
4432 gfc_conv_descriptor_lbound_set (&block, dest,
4433 gfc_rank_cst[n], lbound);
4435 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4436 gfc_conv_descriptor_lbound_get (dest,
4438 gfc_conv_descriptor_stride_get (dest,
4440 gfc_add_modify (&block, tmp2, tmp);
4441 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4443 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4448 /* If a conversion expression has a null data pointer
4449 argument, nullify the allocatable component. */
4453 if (arg->symtree->n.sym->attr.allocatable
4454 || arg->symtree->n.sym->attr.pointer)
4456 non_null_expr = gfc_finish_block (&block);
4457 gfc_start_block (&block);
4458 gfc_conv_descriptor_data_set (&block, dest,
4460 null_expr = gfc_finish_block (&block);
4461 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4462 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4463 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4464 return build3_v (COND_EXPR, tmp,
4465 null_expr, non_null_expr);
4469 return gfc_finish_block (&block);
4473 /* Assign a single component of a derived type constructor. */
4476 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4484 gfc_start_block (&block);
4486 if (cm->attr.pointer)
4488 gfc_init_se (&se, NULL);
4489 /* Pointer component. */
4490 if (cm->attr.dimension)
4492 /* Array pointer. */
4493 if (expr->expr_type == EXPR_NULL)
4494 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4497 rss = gfc_walk_expr (expr);
4498 se.direct_byref = 1;
4500 gfc_conv_expr_descriptor (&se, expr, rss);
4501 gfc_add_block_to_block (&block, &se.pre);
4502 gfc_add_block_to_block (&block, &se.post);
4507 /* Scalar pointers. */
4508 se.want_pointer = 1;
4509 gfc_conv_expr (&se, expr);
4510 gfc_add_block_to_block (&block, &se.pre);
4511 gfc_add_modify (&block, dest,
4512 fold_convert (TREE_TYPE (dest), se.expr));
4513 gfc_add_block_to_block (&block, &se.post);
4516 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4518 /* NULL initialization for CLASS components. */
4519 tmp = gfc_trans_structure_assign (dest,
4520 gfc_class_null_initializer (&cm->ts));
4521 gfc_add_expr_to_block (&block, tmp);
4523 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4525 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4526 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4527 else if (cm->attr.allocatable)
4529 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4530 gfc_add_expr_to_block (&block, tmp);
4534 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4535 gfc_add_expr_to_block (&block, tmp);
4538 else if (expr->ts.type == BT_DERIVED)
4540 if (expr->expr_type != EXPR_STRUCTURE)
4542 gfc_init_se (&se, NULL);
4543 gfc_conv_expr (&se, expr);
4544 gfc_add_block_to_block (&block, &se.pre);
4545 gfc_add_modify (&block, dest,
4546 fold_convert (TREE_TYPE (dest), se.expr));
4547 gfc_add_block_to_block (&block, &se.post);
4551 /* Nested constructors. */
4552 tmp = gfc_trans_structure_assign (dest, expr);
4553 gfc_add_expr_to_block (&block, tmp);
4558 /* Scalar component. */
4559 gfc_init_se (&se, NULL);
4560 gfc_init_se (&lse, NULL);
4562 gfc_conv_expr (&se, expr);
4563 if (cm->ts.type == BT_CHARACTER)
4564 lse.string_length = cm->ts.u.cl->backend_decl;
4566 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4567 gfc_add_expr_to_block (&block, tmp);
4569 return gfc_finish_block (&block);
4572 /* Assign a derived type constructor to a variable. */
4575 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4583 gfc_start_block (&block);
4584 cm = expr->ts.u.derived->components;
4586 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4587 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4588 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4592 gcc_assert (cm->backend_decl == NULL);
4593 gfc_init_se (&se, NULL);
4594 gfc_init_se (&lse, NULL);
4595 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4597 gfc_add_modify (&block, lse.expr,
4598 fold_convert (TREE_TYPE (lse.expr), se.expr));
4600 return gfc_finish_block (&block);
4603 for (c = gfc_constructor_first (expr->value.constructor);
4604 c; c = gfc_constructor_next (c), cm = cm->next)
4606 /* Skip absent members in default initializers. */
4610 field = cm->backend_decl;
4611 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4612 dest, field, NULL_TREE);
4613 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4614 gfc_add_expr_to_block (&block, tmp);
4616 return gfc_finish_block (&block);
4619 /* Build an expression for a constructor. If init is nonzero then
4620 this is part of a static variable initializer. */
4623 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4630 VEC(constructor_elt,gc) *v = NULL;
4632 gcc_assert (se->ss == NULL);
4633 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4634 type = gfc_typenode_for_spec (&expr->ts);
4638 /* Create a temporary variable and fill it in. */
4639 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4640 tmp = gfc_trans_structure_assign (se->expr, expr);
4641 gfc_add_expr_to_block (&se->pre, tmp);
4645 cm = expr->ts.u.derived->components;
4647 for (c = gfc_constructor_first (expr->value.constructor);
4648 c; c = gfc_constructor_next (c), cm = cm->next)
4650 /* Skip absent members in default initializers and allocatable
4651 components. Although the latter have a default initializer
4652 of EXPR_NULL,... by default, the static nullify is not needed
4653 since this is done every time we come into scope. */
4654 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4657 if (strcmp (cm->name, "_size") == 0)
4659 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4660 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4662 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4663 && strcmp (cm->name, "_extends") == 0)
4667 vtabs = cm->initializer->symtree->n.sym;
4668 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4669 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4673 val = gfc_conv_initializer (c->expr, &cm->ts,
4674 TREE_TYPE (cm->backend_decl),
4675 cm->attr.dimension, cm->attr.pointer,
4676 cm->attr.proc_pointer);
4678 /* Append it to the constructor list. */
4679 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4682 se->expr = build_constructor (type, v);
4684 TREE_CONSTANT (se->expr) = 1;
4688 /* Translate a substring expression. */
4691 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4697 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4699 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4700 expr->value.character.length,
4701 expr->value.character.string);
4703 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4704 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4707 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4711 /* Entry point for expression translation. Evaluates a scalar quantity.
4712 EXPR is the expression to be translated, and SE is the state structure if
4713 called from within the scalarized. */
4716 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4718 if (se->ss && se->ss->expr == expr
4719 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4721 /* Substitute a scalar expression evaluated outside the scalarization
4723 se->expr = se->ss->data.scalar.expr;
4724 if (se->ss->type == GFC_SS_REFERENCE)
4725 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4726 se->string_length = se->ss->string_length;
4727 gfc_advance_se_ss_chain (se);
4731 /* We need to convert the expressions for the iso_c_binding derived types.
4732 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4733 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4734 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4735 updated to be an integer with a kind equal to the size of a (void *). */
4736 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4737 && expr->ts.u.derived->attr.is_iso_c)
4739 if (expr->expr_type == EXPR_VARIABLE
4740 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4741 || expr->symtree->n.sym->intmod_sym_id
4742 == ISOCBINDING_NULL_FUNPTR))
4744 /* Set expr_type to EXPR_NULL, which will result in
4745 null_pointer_node being used below. */
4746 expr->expr_type = EXPR_NULL;
4750 /* Update the type/kind of the expression to be what the new
4751 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4752 expr->ts.type = expr->ts.u.derived->ts.type;
4753 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4754 expr->ts.kind = expr->ts.u.derived->ts.kind;
4758 switch (expr->expr_type)
4761 gfc_conv_expr_op (se, expr);
4765 gfc_conv_function_expr (se, expr);
4769 gfc_conv_constant (se, expr);
4773 gfc_conv_variable (se, expr);
4777 se->expr = null_pointer_node;
4780 case EXPR_SUBSTRING:
4781 gfc_conv_substring_expr (se, expr);
4784 case EXPR_STRUCTURE:
4785 gfc_conv_structure (se, expr, 0);
4789 gfc_conv_array_constructor_expr (se, expr);
4798 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4799 of an assignment. */
4801 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4803 gfc_conv_expr (se, expr);
4804 /* All numeric lvalues should have empty post chains. If not we need to
4805 figure out a way of rewriting an lvalue so that it has no post chain. */
4806 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4809 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4810 numeric expressions. Used for scalar values where inserting cleanup code
4813 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4817 gcc_assert (expr->ts.type != BT_CHARACTER);
4818 gfc_conv_expr (se, expr);
4821 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4822 gfc_add_modify (&se->pre, val, se->expr);
4824 gfc_add_block_to_block (&se->pre, &se->post);
4828 /* Helper to translate an expression and convert it to a particular type. */
4830 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4832 gfc_conv_expr_val (se, expr);
4833 se->expr = convert (type, se->expr);
4837 /* Converts an expression so that it can be passed by reference. Scalar
4841 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4845 if (se->ss && se->ss->expr == expr
4846 && se->ss->type == GFC_SS_REFERENCE)
4848 /* Returns a reference to the scalar evaluated outside the loop
4850 gfc_conv_expr (se, expr);
4854 if (expr->ts.type == BT_CHARACTER)
4856 gfc_conv_expr (se, expr);
4857 gfc_conv_string_parameter (se);
4861 if (expr->expr_type == EXPR_VARIABLE)
4863 se->want_pointer = 1;
4864 gfc_conv_expr (se, expr);
4867 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4868 gfc_add_modify (&se->pre, var, se->expr);
4869 gfc_add_block_to_block (&se->pre, &se->post);
4875 if (expr->expr_type == EXPR_FUNCTION
4876 && ((expr->value.function.esym
4877 && expr->value.function.esym->result->attr.pointer
4878 && !expr->value.function.esym->result->attr.dimension)
4879 || (!expr->value.function.esym
4880 && expr->symtree->n.sym->attr.pointer
4881 && !expr->symtree->n.sym->attr.dimension)))
4883 se->want_pointer = 1;
4884 gfc_conv_expr (se, expr);
4885 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4886 gfc_add_modify (&se->pre, var, se->expr);
4892 gfc_conv_expr (se, expr);
4894 /* Create a temporary var to hold the value. */
4895 if (TREE_CONSTANT (se->expr))
4897 tree tmp = se->expr;
4898 STRIP_TYPE_NOPS (tmp);
4899 var = build_decl (input_location,
4900 CONST_DECL, NULL, TREE_TYPE (tmp));
4901 DECL_INITIAL (var) = tmp;
4902 TREE_STATIC (var) = 1;
4907 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4908 gfc_add_modify (&se->pre, var, se->expr);
4910 gfc_add_block_to_block (&se->pre, &se->post);
4912 /* Take the address of that value. */
4913 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4918 gfc_trans_pointer_assign (gfc_code * code)
4920 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4924 /* Generate code for a pointer assignment. */
4927 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4938 gfc_start_block (&block);
4940 gfc_init_se (&lse, NULL);
4942 lss = gfc_walk_expr (expr1);
4943 rss = gfc_walk_expr (expr2);
4944 if (lss == gfc_ss_terminator)
4946 /* Scalar pointers. */
4947 lse.want_pointer = 1;
4948 gfc_conv_expr (&lse, expr1);
4949 gcc_assert (rss == gfc_ss_terminator);
4950 gfc_init_se (&rse, NULL);
4951 rse.want_pointer = 1;
4952 gfc_conv_expr (&rse, expr2);
4954 if (expr1->symtree->n.sym->attr.proc_pointer
4955 && expr1->symtree->n.sym->attr.dummy)
4956 lse.expr = build_fold_indirect_ref_loc (input_location,
4959 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4960 && expr2->symtree->n.sym->attr.dummy)
4961 rse.expr = build_fold_indirect_ref_loc (input_location,
4964 gfc_add_block_to_block (&block, &lse.pre);
4965 gfc_add_block_to_block (&block, &rse.pre);
4967 /* Check character lengths if character expression. The test is only
4968 really added if -fbounds-check is enabled. Exclude deferred
4969 character length lefthand sides. */
4970 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4971 && !(expr1->ts.deferred
4972 && (TREE_CODE (lse.string_length) == VAR_DECL))
4973 && !expr1->symtree->n.sym->attr.proc_pointer
4974 && !gfc_is_proc_ptr_comp (expr1, NULL))
4976 gcc_assert (expr2->ts.type == BT_CHARACTER);
4977 gcc_assert (lse.string_length && rse.string_length);
4978 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4979 lse.string_length, rse.string_length,
4983 /* The assignment to an deferred character length sets the string
4984 length to that of the rhs. */
4985 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4987 if (expr2->expr_type != EXPR_NULL)
4988 gfc_add_modify (&block, lse.string_length, rse.string_length);
4990 gfc_add_modify (&block, lse.string_length,
4991 build_int_cst (gfc_charlen_type_node, 0));
4994 gfc_add_modify (&block, lse.expr,
4995 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4997 gfc_add_block_to_block (&block, &rse.post);
4998 gfc_add_block_to_block (&block, &lse.post);
5005 tree strlen_rhs = NULL_TREE;
5007 /* Array pointer. Find the last reference on the LHS and if it is an
5008 array section ref, we're dealing with bounds remapping. In this case,
5009 set it to AR_FULL so that gfc_conv_expr_descriptor does
5010 not see it and process the bounds remapping afterwards explicitely. */
5011 for (remap = expr1->ref; remap; remap = remap->next)
5012 if (!remap->next && remap->type == REF_ARRAY
5013 && remap->u.ar.type == AR_SECTION)
5015 remap->u.ar.type = AR_FULL;
5018 rank_remap = (remap && remap->u.ar.end[0]);
5020 gfc_conv_expr_descriptor (&lse, expr1, lss);
5021 strlen_lhs = lse.string_length;
5024 if (expr2->expr_type == EXPR_NULL)
5026 /* Just set the data pointer to null. */
5027 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5029 else if (rank_remap)
5031 /* If we are rank-remapping, just get the RHS's descriptor and
5032 process this later on. */
5033 gfc_init_se (&rse, NULL);
5034 rse.direct_byref = 1;
5035 rse.byref_noassign = 1;
5036 gfc_conv_expr_descriptor (&rse, expr2, rss);
5037 strlen_rhs = rse.string_length;
5039 else if (expr2->expr_type == EXPR_VARIABLE)
5041 /* Assign directly to the LHS's descriptor. */
5042 lse.direct_byref = 1;
5043 gfc_conv_expr_descriptor (&lse, expr2, rss);
5044 strlen_rhs = lse.string_length;
5046 /* If this is a subreference array pointer assignment, use the rhs
5047 descriptor element size for the lhs span. */
5048 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5050 decl = expr1->symtree->n.sym->backend_decl;
5051 gfc_init_se (&rse, NULL);
5052 rse.descriptor_only = 1;
5053 gfc_conv_expr (&rse, expr2);
5054 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5055 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5056 if (!INTEGER_CST_P (tmp))
5057 gfc_add_block_to_block (&lse.post, &rse.pre);
5058 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5063 /* Assign to a temporary descriptor and then copy that
5064 temporary to the pointer. */
5065 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5068 lse.direct_byref = 1;
5069 gfc_conv_expr_descriptor (&lse, expr2, rss);
5070 strlen_rhs = lse.string_length;
5071 gfc_add_modify (&lse.pre, desc, tmp);
5074 gfc_add_block_to_block (&block, &lse.pre);
5076 gfc_add_block_to_block (&block, &rse.pre);
5078 /* If we do bounds remapping, update LHS descriptor accordingly. */
5082 gcc_assert (remap->u.ar.dimen == expr1->rank);
5086 /* Do rank remapping. We already have the RHS's descriptor
5087 converted in rse and now have to build the correct LHS
5088 descriptor for it. */
5092 tree lbound, ubound;
5095 dtype = gfc_conv_descriptor_dtype (desc);
5096 tmp = gfc_get_dtype (TREE_TYPE (desc));
5097 gfc_add_modify (&block, dtype, tmp);
5099 /* Copy data pointer. */
5100 data = gfc_conv_descriptor_data_get (rse.expr);
5101 gfc_conv_descriptor_data_set (&block, desc, data);
5103 /* Copy offset but adjust it such that it would correspond
5104 to a lbound of zero. */
5105 offs = gfc_conv_descriptor_offset_get (rse.expr);
5106 for (dim = 0; dim < expr2->rank; ++dim)
5108 stride = gfc_conv_descriptor_stride_get (rse.expr,
5110 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5112 tmp = fold_build2_loc (input_location, MULT_EXPR,
5113 gfc_array_index_type, stride, lbound);
5114 offs = fold_build2_loc (input_location, PLUS_EXPR,
5115 gfc_array_index_type, offs, tmp);
5117 gfc_conv_descriptor_offset_set (&block, desc, offs);
5119 /* Set the bounds as declared for the LHS and calculate strides as
5120 well as another offset update accordingly. */
5121 stride = gfc_conv_descriptor_stride_get (rse.expr,
5123 for (dim = 0; dim < expr1->rank; ++dim)
5128 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5130 /* Convert declared bounds. */
5131 gfc_init_se (&lower_se, NULL);
5132 gfc_init_se (&upper_se, NULL);
5133 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5134 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5136 gfc_add_block_to_block (&block, &lower_se.pre);
5137 gfc_add_block_to_block (&block, &upper_se.pre);
5139 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5140 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5142 lbound = gfc_evaluate_now (lbound, &block);
5143 ubound = gfc_evaluate_now (ubound, &block);
5145 gfc_add_block_to_block (&block, &lower_se.post);
5146 gfc_add_block_to_block (&block, &upper_se.post);
5148 /* Set bounds in descriptor. */
5149 gfc_conv_descriptor_lbound_set (&block, desc,
5150 gfc_rank_cst[dim], lbound);
5151 gfc_conv_descriptor_ubound_set (&block, desc,
5152 gfc_rank_cst[dim], ubound);
5155 stride = gfc_evaluate_now (stride, &block);
5156 gfc_conv_descriptor_stride_set (&block, desc,
5157 gfc_rank_cst[dim], stride);
5159 /* Update offset. */
5160 offs = gfc_conv_descriptor_offset_get (desc);
5161 tmp = fold_build2_loc (input_location, MULT_EXPR,
5162 gfc_array_index_type, lbound, stride);
5163 offs = fold_build2_loc (input_location, MINUS_EXPR,
5164 gfc_array_index_type, offs, tmp);
5165 offs = gfc_evaluate_now (offs, &block);
5166 gfc_conv_descriptor_offset_set (&block, desc, offs);
5168 /* Update stride. */
5169 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5170 stride = fold_build2_loc (input_location, MULT_EXPR,
5171 gfc_array_index_type, stride, tmp);
5176 /* Bounds remapping. Just shift the lower bounds. */
5178 gcc_assert (expr1->rank == expr2->rank);
5180 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5184 gcc_assert (remap->u.ar.start[dim]);
5185 gcc_assert (!remap->u.ar.end[dim]);
5186 gfc_init_se (&lbound_se, NULL);
5187 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5189 gfc_add_block_to_block (&block, &lbound_se.pre);
5190 gfc_conv_shift_descriptor_lbound (&block, desc,
5191 dim, lbound_se.expr);
5192 gfc_add_block_to_block (&block, &lbound_se.post);
5197 /* Check string lengths if applicable. The check is only really added
5198 to the output code if -fbounds-check is enabled. */
5199 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5201 gcc_assert (expr2->ts.type == BT_CHARACTER);
5202 gcc_assert (strlen_lhs && strlen_rhs);
5203 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5204 strlen_lhs, strlen_rhs, &block);
5207 /* If rank remapping was done, check with -fcheck=bounds that
5208 the target is at least as large as the pointer. */
5209 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5215 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5216 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5218 lsize = gfc_evaluate_now (lsize, &block);
5219 rsize = gfc_evaluate_now (rsize, &block);
5220 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5223 msg = _("Target of rank remapping is too small (%ld < %ld)");
5224 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5228 gfc_add_block_to_block (&block, &lse.post);
5230 gfc_add_block_to_block (&block, &rse.post);
5233 return gfc_finish_block (&block);
5237 /* Makes sure se is suitable for passing as a function string parameter. */
5238 /* TODO: Need to check all callers of this function. It may be abused. */
5241 gfc_conv_string_parameter (gfc_se * se)
5245 if (TREE_CODE (se->expr) == STRING_CST)
5247 type = TREE_TYPE (TREE_TYPE (se->expr));
5248 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5252 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5254 if (TREE_CODE (se->expr) != INDIRECT_REF)
5256 type = TREE_TYPE (se->expr);
5257 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5261 type = gfc_get_character_type_len (gfc_default_character_kind,
5263 type = build_pointer_type (type);
5264 se->expr = gfc_build_addr_expr (type, se->expr);
5268 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5272 /* Generate code for assignment of scalar variables. Includes character
5273 strings and derived types with allocatable components.
5274 If you know that the LHS has no allocations, set dealloc to false. */
5277 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5278 bool l_is_temp, bool r_is_var, bool dealloc)
5284 gfc_init_block (&block);
5286 if (ts.type == BT_CHARACTER)
5291 if (lse->string_length != NULL_TREE)
5293 gfc_conv_string_parameter (lse);
5294 gfc_add_block_to_block (&block, &lse->pre);
5295 llen = lse->string_length;
5298 if (rse->string_length != NULL_TREE)
5300 gcc_assert (rse->string_length != NULL_TREE);
5301 gfc_conv_string_parameter (rse);
5302 gfc_add_block_to_block (&block, &rse->pre);
5303 rlen = rse->string_length;
5306 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5307 rse->expr, ts.kind);
5309 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5313 /* Are the rhs and the lhs the same? */
5316 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5317 gfc_build_addr_expr (NULL_TREE, lse->expr),
5318 gfc_build_addr_expr (NULL_TREE, rse->expr));
5319 cond = gfc_evaluate_now (cond, &lse->pre);
5322 /* Deallocate the lhs allocated components as long as it is not
5323 the same as the rhs. This must be done following the assignment
5324 to prevent deallocating data that could be used in the rhs
5326 if (!l_is_temp && dealloc)
5328 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5329 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5331 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5333 gfc_add_expr_to_block (&lse->post, tmp);
5336 gfc_add_block_to_block (&block, &rse->pre);
5337 gfc_add_block_to_block (&block, &lse->pre);
5339 gfc_add_modify (&block, lse->expr,
5340 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5342 /* Do a deep copy if the rhs is a variable, if it is not the
5346 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5347 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5349 gfc_add_expr_to_block (&block, tmp);
5352 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5354 gfc_add_block_to_block (&block, &lse->pre);
5355 gfc_add_block_to_block (&block, &rse->pre);
5356 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5357 TREE_TYPE (lse->expr), rse->expr);
5358 gfc_add_modify (&block, lse->expr, tmp);
5362 gfc_add_block_to_block (&block, &lse->pre);
5363 gfc_add_block_to_block (&block, &rse->pre);
5365 gfc_add_modify (&block, lse->expr,
5366 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5369 gfc_add_block_to_block (&block, &lse->post);
5370 gfc_add_block_to_block (&block, &rse->post);
5372 return gfc_finish_block (&block);
5376 /* There are quite a lot of restrictions on the optimisation in using an
5377 array function assign without a temporary. */
5380 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5383 bool seen_array_ref;
5385 gfc_symbol *sym = expr1->symtree->n.sym;
5387 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5388 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5391 /* Elemental functions are scalarized so that they don't need a
5392 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5393 they would need special treatment in gfc_trans_arrayfunc_assign. */
5394 if (expr2->value.function.esym != NULL
5395 && expr2->value.function.esym->attr.elemental)
5398 /* Need a temporary if rhs is not FULL or a contiguous section. */
5399 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5402 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5403 if (gfc_ref_needs_temporary_p (expr1->ref))
5406 /* Functions returning pointers or allocatables need temporaries. */
5407 c = expr2->value.function.esym
5408 ? (expr2->value.function.esym->attr.pointer
5409 || expr2->value.function.esym->attr.allocatable)
5410 : (expr2->symtree->n.sym->attr.pointer
5411 || expr2->symtree->n.sym->attr.allocatable);
5415 /* Character array functions need temporaries unless the
5416 character lengths are the same. */
5417 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5419 if (expr1->ts.u.cl->length == NULL
5420 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5423 if (expr2->ts.u.cl->length == NULL
5424 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5427 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5428 expr2->ts.u.cl->length->value.integer) != 0)
5432 /* Check that no LHS component references appear during an array
5433 reference. This is needed because we do not have the means to
5434 span any arbitrary stride with an array descriptor. This check
5435 is not needed for the rhs because the function result has to be
5437 seen_array_ref = false;
5438 for (ref = expr1->ref; ref; ref = ref->next)
5440 if (ref->type == REF_ARRAY)
5441 seen_array_ref= true;
5442 else if (ref->type == REF_COMPONENT && seen_array_ref)
5446 /* Check for a dependency. */
5447 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5448 expr2->value.function.esym,
5449 expr2->value.function.actual,
5453 /* If we have reached here with an intrinsic function, we do not
5454 need a temporary except in the particular case that reallocation
5455 on assignment is active and the lhs is allocatable and a target. */
5456 if (expr2->value.function.isym)
5457 return (gfc_option.flag_realloc_lhs
5458 && sym->attr.allocatable
5459 && sym->attr.target);
5461 /* If the LHS is a dummy, we need a temporary if it is not
5463 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5466 /* If the lhs has been host_associated, is in common, a pointer or is
5467 a target and the function is not using a RESULT variable, aliasing
5468 can occur and a temporary is needed. */
5469 if ((sym->attr.host_assoc
5470 || sym->attr.in_common
5471 || sym->attr.pointer
5472 || sym->attr.cray_pointee
5473 || sym->attr.target)
5474 && expr2->symtree != NULL
5475 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5478 /* A PURE function can unconditionally be called without a temporary. */
5479 if (expr2->value.function.esym != NULL
5480 && expr2->value.function.esym->attr.pure)
5483 /* Implicit_pure functions are those which could legally be declared
5485 if (expr2->value.function.esym != NULL
5486 && expr2->value.function.esym->attr.implicit_pure)
5489 if (!sym->attr.use_assoc
5490 && !sym->attr.in_common
5491 && !sym->attr.pointer
5492 && !sym->attr.target
5493 && !sym->attr.cray_pointee
5494 && expr2->value.function.esym)
5496 /* A temporary is not needed if the function is not contained and
5497 the variable is local or host associated and not a pointer or
5499 if (!expr2->value.function.esym->attr.contained)
5502 /* A temporary is not needed if the lhs has never been host
5503 associated and the procedure is contained. */
5504 else if (!sym->attr.host_assoc)
5507 /* A temporary is not needed if the variable is local and not
5508 a pointer, a target or a result. */
5510 && expr2->value.function.esym->ns == sym->ns->parent)
5514 /* Default to temporary use. */
5519 /* Provide the loop info so that the lhs descriptor can be built for
5520 reallocatable assignments from extrinsic function calls. */
5523 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5526 /* Signal that the function call should not be made by
5527 gfc_conv_loop_setup. */
5528 se->ss->is_alloc_lhs = 1;
5529 gfc_init_loopinfo (loop);
5530 gfc_add_ss_to_loop (loop, *ss);
5531 gfc_add_ss_to_loop (loop, se->ss);
5532 gfc_conv_ss_startstride (loop);
5533 gfc_conv_loop_setup (loop, where);
5534 gfc_copy_loopinfo_to_se (se, loop);
5535 gfc_add_block_to_block (&se->pre, &loop->pre);
5536 gfc_add_block_to_block (&se->pre, &loop->post);
5537 se->ss->is_alloc_lhs = 0;
5541 /* For Assignment to a reallocatable lhs from intrinsic functions,
5542 replace the se.expr (ie. the result) with a temporary descriptor.
5543 Null the data field so that the library allocates space for the
5544 result. Free the data of the original descriptor after the function,
5545 in case it appears in an argument expression and transfer the
5546 result to the original descriptor. */
5549 fcncall_realloc_result (gfc_se *se, int rank)
5557 /* Use the allocation done by the library. Substitute the lhs
5558 descriptor with a copy, whose data field is nulled.*/
5559 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5560 /* Unallocated, the descriptor does not have a dtype. */
5561 tmp = gfc_conv_descriptor_dtype (desc);
5562 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5563 res_desc = gfc_evaluate_now (desc, &se->pre);
5564 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5565 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5567 /* Free the lhs after the function call and copy the result to
5568 the lhs descriptor. */
5569 tmp = gfc_conv_descriptor_data_get (desc);
5570 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5571 gfc_add_expr_to_block (&se->post, tmp);
5572 gfc_add_modify (&se->post, desc, res_desc);
5574 offset = gfc_index_zero_node;
5575 tmp = gfc_index_one_node;
5576 /* Now reset the bounds from zero based to unity based. */
5577 for (n = 0 ; n < rank; n++)
5579 /* Accumulate the offset. */
5580 offset = fold_build2_loc (input_location, MINUS_EXPR,
5581 gfc_array_index_type,
5583 /* Now do the bounds. */
5584 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5585 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5586 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5587 gfc_array_index_type,
5588 tmp, gfc_index_one_node);
5589 gfc_conv_descriptor_lbound_set (&se->post, desc,
5591 gfc_index_one_node);
5592 gfc_conv_descriptor_ubound_set (&se->post, desc,
5593 gfc_rank_cst[n], tmp);
5595 /* The extent for the next contribution to offset. */
5596 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5597 gfc_array_index_type,
5598 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5599 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5600 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5601 gfc_array_index_type,
5602 tmp, gfc_index_one_node);
5604 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5609 /* Try to translate array(:) = func (...), where func is a transformational
5610 array function, without using a temporary. Returns NULL if this isn't the
5614 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5618 gfc_component *comp = NULL;
5621 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5624 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5626 gcc_assert (expr2->value.function.isym
5627 || (gfc_is_proc_ptr_comp (expr2, &comp)
5628 && comp && comp->attr.dimension)
5629 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5630 && expr2->value.function.esym->result->attr.dimension));
5632 ss = gfc_walk_expr (expr1);
5633 gcc_assert (ss != gfc_ss_terminator);
5634 gfc_init_se (&se, NULL);
5635 gfc_start_block (&se.pre);
5636 se.want_pointer = 1;
5638 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5640 if (expr1->ts.type == BT_DERIVED
5641 && expr1->ts.u.derived->attr.alloc_comp)
5644 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5646 gfc_add_expr_to_block (&se.pre, tmp);
5649 se.direct_byref = 1;
5650 se.ss = gfc_walk_expr (expr2);
5651 gcc_assert (se.ss != gfc_ss_terminator);
5653 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5654 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5655 Clearly, this cannot be done for an allocatable function result, since
5656 the shape of the result is unknown and, in any case, the function must
5657 correctly take care of the reallocation internally. For intrinsic
5658 calls, the array data is freed and the library takes care of allocation.
5659 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5661 if (gfc_option.flag_realloc_lhs
5662 && gfc_is_reallocatable_lhs (expr1)
5663 && !gfc_expr_attr (expr1).codimension
5664 && !gfc_is_coindexed (expr1)
5665 && !(expr2->value.function.esym
5666 && expr2->value.function.esym->result->attr.allocatable))
5668 if (!expr2->value.function.isym)
5670 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5671 ss->is_alloc_lhs = 1;
5674 fcncall_realloc_result (&se, expr1->rank);
5677 gfc_conv_function_expr (&se, expr2);
5678 gfc_add_block_to_block (&se.pre, &se.post);
5680 return gfc_finish_block (&se.pre);
5684 /* Try to efficiently translate array(:) = 0. Return NULL if this
5688 gfc_trans_zero_assign (gfc_expr * expr)
5690 tree dest, len, type;
5694 sym = expr->symtree->n.sym;
5695 dest = gfc_get_symbol_decl (sym);
5697 type = TREE_TYPE (dest);
5698 if (POINTER_TYPE_P (type))
5699 type = TREE_TYPE (type);
5700 if (!GFC_ARRAY_TYPE_P (type))
5703 /* Determine the length of the array. */
5704 len = GFC_TYPE_ARRAY_SIZE (type);
5705 if (!len || TREE_CODE (len) != INTEGER_CST)
5708 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5709 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5710 fold_convert (gfc_array_index_type, tmp));
5712 /* If we are zeroing a local array avoid taking its address by emitting
5714 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5715 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5716 dest, build_constructor (TREE_TYPE (dest), NULL));
5718 /* Convert arguments to the correct types. */
5719 dest = fold_convert (pvoid_type_node, dest);
5720 len = fold_convert (size_type_node, len);
5722 /* Construct call to __builtin_memset. */
5723 tmp = build_call_expr_loc (input_location,
5724 built_in_decls[BUILT_IN_MEMSET],
5725 3, dest, integer_zero_node, len);
5726 return fold_convert (void_type_node, tmp);
5730 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5731 that constructs the call to __builtin_memcpy. */
5734 gfc_build_memcpy_call (tree dst, tree src, tree len)
5738 /* Convert arguments to the correct types. */
5739 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5740 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5742 dst = fold_convert (pvoid_type_node, dst);
5744 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5745 src = gfc_build_addr_expr (pvoid_type_node, src);
5747 src = fold_convert (pvoid_type_node, src);
5749 len = fold_convert (size_type_node, len);
5751 /* Construct call to __builtin_memcpy. */
5752 tmp = build_call_expr_loc (input_location,
5753 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5754 return fold_convert (void_type_node, tmp);
5758 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5759 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5760 source/rhs, both are gfc_full_array_ref_p which have been checked for
5764 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5766 tree dst, dlen, dtype;
5767 tree src, slen, stype;
5770 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5771 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5773 dtype = TREE_TYPE (dst);
5774 if (POINTER_TYPE_P (dtype))
5775 dtype = TREE_TYPE (dtype);
5776 stype = TREE_TYPE (src);
5777 if (POINTER_TYPE_P (stype))
5778 stype = TREE_TYPE (stype);
5780 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5783 /* Determine the lengths of the arrays. */
5784 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5785 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5787 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5788 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5789 dlen, fold_convert (gfc_array_index_type, tmp));
5791 slen = GFC_TYPE_ARRAY_SIZE (stype);
5792 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5794 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5795 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5796 slen, fold_convert (gfc_array_index_type, tmp));
5798 /* Sanity check that they are the same. This should always be
5799 the case, as we should already have checked for conformance. */
5800 if (!tree_int_cst_equal (slen, dlen))
5803 return gfc_build_memcpy_call (dst, src, dlen);
5807 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5808 this can't be done. EXPR1 is the destination/lhs for which
5809 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5812 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5814 unsigned HOST_WIDE_INT nelem;
5820 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5824 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5825 dtype = TREE_TYPE (dst);
5826 if (POINTER_TYPE_P (dtype))
5827 dtype = TREE_TYPE (dtype);
5828 if (!GFC_ARRAY_TYPE_P (dtype))
5831 /* Determine the lengths of the array. */
5832 len = GFC_TYPE_ARRAY_SIZE (dtype);
5833 if (!len || TREE_CODE (len) != INTEGER_CST)
5836 /* Confirm that the constructor is the same size. */
5837 if (compare_tree_int (len, nelem) != 0)
5840 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5841 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5842 fold_convert (gfc_array_index_type, tmp));
5844 stype = gfc_typenode_for_spec (&expr2->ts);
5845 src = gfc_build_constant_array_constructor (expr2, stype);
5847 stype = TREE_TYPE (src);
5848 if (POINTER_TYPE_P (stype))
5849 stype = TREE_TYPE (stype);
5851 return gfc_build_memcpy_call (dst, src, len);
5855 /* Tells whether the expression is to be treated as a variable reference. */
5858 expr_is_variable (gfc_expr *expr)
5862 if (expr->expr_type == EXPR_VARIABLE)
5865 arg = gfc_get_noncopying_intrinsic_argument (expr);
5868 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5869 return expr_is_variable (arg);
5876 /* Is the lhs OK for automatic reallocation? */
5879 is_scalar_reallocatable_lhs (gfc_expr *expr)
5883 /* An allocatable variable with no reference. */
5884 if (expr->symtree->n.sym->attr.allocatable
5888 /* All that can be left are allocatable components. */
5889 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5890 && expr->symtree->n.sym->ts.type != BT_CLASS)
5891 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5894 /* Find an allocatable component ref last. */
5895 for (ref = expr->ref; ref; ref = ref->next)
5896 if (ref->type == REF_COMPONENT
5898 && ref->u.c.component->attr.allocatable)
5905 /* Allocate or reallocate scalar lhs, as necessary. */
5908 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5922 if (!expr1 || expr1->rank)
5925 if (!expr2 || expr2->rank)
5928 /* Since this is a scalar lhs, we can afford to do this. That is,
5929 there is no risk of side effects being repeated. */
5930 gfc_init_se (&lse, NULL);
5931 lse.want_pointer = 1;
5932 gfc_conv_expr (&lse, expr1);
5934 jump_label1 = gfc_build_label_decl (NULL_TREE);
5935 jump_label2 = gfc_build_label_decl (NULL_TREE);
5937 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5938 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5939 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5941 tmp = build3_v (COND_EXPR, cond,
5942 build1_v (GOTO_EXPR, jump_label1),
5943 build_empty_stmt (input_location));
5944 gfc_add_expr_to_block (block, tmp);
5946 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5948 /* Use the rhs string length and the lhs element size. */
5949 size = string_length;
5950 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5951 tmp = TYPE_SIZE_UNIT (tmp);
5952 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5953 TREE_TYPE (tmp), tmp,
5954 fold_convert (TREE_TYPE (tmp), size));
5958 /* Otherwise use the length in bytes of the rhs. */
5959 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5960 size_in_bytes = size;
5963 tmp = build_call_expr_loc (input_location,
5964 built_in_decls[BUILT_IN_MALLOC], 1,
5966 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5967 gfc_add_modify (block, lse.expr, tmp);
5968 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5970 /* Deferred characters need checking for lhs and rhs string
5971 length. Other deferred parameter variables will have to
5973 tmp = build1_v (GOTO_EXPR, jump_label2);
5974 gfc_add_expr_to_block (block, tmp);
5976 tmp = build1_v (LABEL_EXPR, jump_label1);
5977 gfc_add_expr_to_block (block, tmp);
5979 /* For a deferred length character, reallocate if lengths of lhs and
5980 rhs are different. */
5981 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5983 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5984 expr1->ts.u.cl->backend_decl, size);
5985 /* Jump past the realloc if the lengths are the same. */
5986 tmp = build3_v (COND_EXPR, cond,
5987 build1_v (GOTO_EXPR, jump_label2),
5988 build_empty_stmt (input_location));
5989 gfc_add_expr_to_block (block, tmp);
5990 tmp = build_call_expr_loc (input_location,
5991 built_in_decls[BUILT_IN_REALLOC], 2,
5992 fold_convert (pvoid_type_node, lse.expr),
5994 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5995 gfc_add_modify (block, lse.expr, tmp);
5996 tmp = build1_v (LABEL_EXPR, jump_label2);
5997 gfc_add_expr_to_block (block, tmp);
5999 /* Update the lhs character length. */
6000 size = string_length;
6001 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6006 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6007 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6008 init_flag indicates initialization expressions and dealloc that no
6009 deallocate prior assignment is needed (if in doubt, set true). */
6012 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6018 gfc_ss *lss_section;
6025 bool scalar_to_array;
6030 /* Assignment of the form lhs = rhs. */
6031 gfc_start_block (&block);
6033 gfc_init_se (&lse, NULL);
6034 gfc_init_se (&rse, NULL);
6037 lss = gfc_walk_expr (expr1);
6038 if (gfc_is_reallocatable_lhs (expr1)
6039 && !(expr2->expr_type == EXPR_FUNCTION
6040 && expr2->value.function.isym != NULL))
6041 lss->is_alloc_lhs = 1;
6043 if (lss != gfc_ss_terminator)
6045 /* Allow the scalarizer to workshare array assignments. */
6046 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6047 ompws_flags |= OMPWS_SCALARIZER_WS;
6049 /* The assignment needs scalarization. */
6052 /* Find a non-scalar SS from the lhs. */
6053 while (lss_section != gfc_ss_terminator
6054 && lss_section->type != GFC_SS_SECTION)
6055 lss_section = lss_section->next;
6057 gcc_assert (lss_section != gfc_ss_terminator);
6059 /* Initialize the scalarizer. */
6060 gfc_init_loopinfo (&loop);
6063 rss = gfc_walk_expr (expr2);
6064 if (rss == gfc_ss_terminator)
6066 /* The rhs is scalar. Add a ss for the expression. */
6067 rss = gfc_get_ss ();
6068 rss->next = gfc_ss_terminator;
6069 rss->type = GFC_SS_SCALAR;
6072 /* Associate the SS with the loop. */
6073 gfc_add_ss_to_loop (&loop, lss);
6074 gfc_add_ss_to_loop (&loop, rss);
6076 /* Calculate the bounds of the scalarization. */
6077 gfc_conv_ss_startstride (&loop);
6078 /* Enable loop reversal. */
6079 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6080 loop.reverse[n] = GFC_ENABLE_REVERSE;
6081 /* Resolve any data dependencies in the statement. */
6082 gfc_conv_resolve_dependencies (&loop, lss, rss);
6083 /* Setup the scalarizing loops. */
6084 gfc_conv_loop_setup (&loop, &expr2->where);
6086 /* Setup the gfc_se structures. */
6087 gfc_copy_loopinfo_to_se (&lse, &loop);
6088 gfc_copy_loopinfo_to_se (&rse, &loop);
6091 gfc_mark_ss_chain_used (rss, 1);
6092 if (loop.temp_ss == NULL)
6095 gfc_mark_ss_chain_used (lss, 1);
6099 lse.ss = loop.temp_ss;
6100 gfc_mark_ss_chain_used (lss, 3);
6101 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6104 /* Start the scalarized loop body. */
6105 gfc_start_scalarized_body (&loop, &body);
6108 gfc_init_block (&body);
6110 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6112 /* Translate the expression. */
6113 gfc_conv_expr (&rse, expr2);
6115 /* Stabilize a string length for temporaries. */
6116 if (expr2->ts.type == BT_CHARACTER)
6117 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6119 string_length = NULL_TREE;
6123 gfc_conv_tmp_array_ref (&lse);
6124 if (expr2->ts.type == BT_CHARACTER)
6125 lse.string_length = string_length;
6128 gfc_conv_expr (&lse, expr1);
6130 /* Assignments of scalar derived types with allocatable components
6131 to arrays must be done with a deep copy and the rhs temporary
6132 must have its components deallocated afterwards. */
6133 scalar_to_array = (expr2->ts.type == BT_DERIVED
6134 && expr2->ts.u.derived->attr.alloc_comp
6135 && !expr_is_variable (expr2)
6136 && !gfc_is_constant_expr (expr2)
6137 && expr1->rank && !expr2->rank);
6138 if (scalar_to_array && dealloc)
6140 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6141 gfc_add_expr_to_block (&loop.post, tmp);
6144 /* For a deferred character length function, the function call must
6145 happen before the (re)allocation of the lhs, otherwise the character
6146 length of the result is not known. */
6147 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6148 || (expr2->expr_type == EXPR_COMPCALL)
6149 || (expr2->expr_type == EXPR_PPC))
6150 && expr2->ts.deferred);
6151 if (gfc_option.flag_realloc_lhs
6152 && expr2->ts.type == BT_CHARACTER
6153 && (def_clen_func || expr2->expr_type == EXPR_OP)
6154 && expr1->ts.deferred)
6155 gfc_add_block_to_block (&block, &rse.pre);
6157 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6158 l_is_temp || init_flag,
6159 expr_is_variable (expr2) || scalar_to_array
6160 || expr2->expr_type == EXPR_ARRAY, dealloc);
6161 gfc_add_expr_to_block (&body, tmp);
6163 if (lss == gfc_ss_terminator)
6165 /* F2003: Add the code for reallocation on assignment. */
6166 if (gfc_option.flag_realloc_lhs
6167 && is_scalar_reallocatable_lhs (expr1))
6168 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6171 /* Use the scalar assignment as is. */
6172 gfc_add_block_to_block (&block, &body);
6176 gcc_assert (lse.ss == gfc_ss_terminator
6177 && rse.ss == gfc_ss_terminator);
6181 gfc_trans_scalarized_loop_boundary (&loop, &body);
6183 /* We need to copy the temporary to the actual lhs. */
6184 gfc_init_se (&lse, NULL);
6185 gfc_init_se (&rse, NULL);
6186 gfc_copy_loopinfo_to_se (&lse, &loop);
6187 gfc_copy_loopinfo_to_se (&rse, &loop);
6189 rse.ss = loop.temp_ss;
6192 gfc_conv_tmp_array_ref (&rse);
6193 gfc_conv_expr (&lse, expr1);
6195 gcc_assert (lse.ss == gfc_ss_terminator
6196 && rse.ss == gfc_ss_terminator);
6198 if (expr2->ts.type == BT_CHARACTER)
6199 rse.string_length = string_length;
6201 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6202 false, false, dealloc);
6203 gfc_add_expr_to_block (&body, tmp);
6206 /* F2003: Allocate or reallocate lhs of allocatable array. */
6207 if (gfc_option.flag_realloc_lhs
6208 && gfc_is_reallocatable_lhs (expr1)
6209 && !gfc_expr_attr (expr1).codimension
6210 && !gfc_is_coindexed (expr1))
6212 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6213 if (tmp != NULL_TREE)
6214 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6217 /* Generate the copying loops. */
6218 gfc_trans_scalarizing_loops (&loop, &body);
6220 /* Wrap the whole thing up. */
6221 gfc_add_block_to_block (&block, &loop.pre);
6222 gfc_add_block_to_block (&block, &loop.post);
6224 gfc_cleanup_loop (&loop);
6227 return gfc_finish_block (&block);
6231 /* Check whether EXPR is a copyable array. */
6234 copyable_array_p (gfc_expr * expr)
6236 if (expr->expr_type != EXPR_VARIABLE)
6239 /* First check it's an array. */
6240 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6243 if (!gfc_full_array_ref_p (expr->ref, NULL))
6246 /* Next check that it's of a simple enough type. */
6247 switch (expr->ts.type)
6259 return !expr->ts.u.derived->attr.alloc_comp;
6268 /* Translate an assignment. */
6271 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6276 /* Special case a single function returning an array. */
6277 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6279 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6284 /* Special case assigning an array to zero. */
6285 if (copyable_array_p (expr1)
6286 && is_zero_initializer_p (expr2))
6288 tmp = gfc_trans_zero_assign (expr1);
6293 /* Special case copying one array to another. */
6294 if (copyable_array_p (expr1)
6295 && copyable_array_p (expr2)
6296 && gfc_compare_types (&expr1->ts, &expr2->ts)
6297 && !gfc_check_dependency (expr1, expr2, 0))
6299 tmp = gfc_trans_array_copy (expr1, expr2);
6304 /* Special case initializing an array from a constant array constructor. */
6305 if (copyable_array_p (expr1)
6306 && expr2->expr_type == EXPR_ARRAY
6307 && gfc_compare_types (&expr1->ts, &expr2->ts))
6309 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6314 /* Fallback to the scalarizer to generate explicit loops. */
6315 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6319 gfc_trans_init_assign (gfc_code * code)
6321 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6325 gfc_trans_assign (gfc_code * code)
6327 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6331 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6332 A MEMCPY is needed to copy the full data from the default initializer
6333 of the dynamic type. */
6336 gfc_trans_class_init_assign (gfc_code *code)
6340 gfc_se dst,src,memsz;
6341 gfc_expr *lhs,*rhs,*sz;
6343 gfc_start_block (&block);
6345 lhs = gfc_copy_expr (code->expr1);
6346 gfc_add_data_component (lhs);
6348 rhs = gfc_copy_expr (code->expr1);
6349 gfc_add_vptr_component (rhs);
6351 /* Make sure that the component backend_decls have been built, which
6352 will not have happened if the derived types concerned have not
6354 gfc_get_derived_type (rhs->ts.u.derived);
6355 gfc_add_def_init_component (rhs);
6357 sz = gfc_copy_expr (code->expr1);
6358 gfc_add_vptr_component (sz);
6359 gfc_add_size_component (sz);
6361 gfc_init_se (&dst, NULL);
6362 gfc_init_se (&src, NULL);
6363 gfc_init_se (&memsz, NULL);
6364 gfc_conv_expr (&dst, lhs);
6365 gfc_conv_expr (&src, rhs);
6366 gfc_conv_expr (&memsz, sz);
6367 gfc_add_block_to_block (&block, &src.pre);
6368 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6369 gfc_add_expr_to_block (&block, tmp);
6371 return gfc_finish_block (&block);
6375 /* Translate an assignment to a CLASS object
6376 (pointer or ordinary assignment). */
6379 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6386 gfc_start_block (&block);
6388 if (expr2->ts.type != BT_CLASS)
6390 /* Insert an additional assignment which sets the '_vptr' field. */
6391 gfc_symbol *vtab = NULL;
6394 lhs = gfc_copy_expr (expr1);
6395 gfc_add_vptr_component (lhs);
6397 if (expr2->ts.type == BT_DERIVED)
6398 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6399 else if (expr2->expr_type == EXPR_NULL)
6400 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6403 rhs = gfc_get_expr ();
6404 rhs->expr_type = EXPR_VARIABLE;
6405 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6409 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6410 gfc_add_expr_to_block (&block, tmp);
6412 gfc_free_expr (lhs);
6413 gfc_free_expr (rhs);
6416 /* Do the actual CLASS assignment. */
6417 if (expr2->ts.type == BT_CLASS)
6420 gfc_add_data_component (expr1);
6422 if (op == EXEC_ASSIGN)
6423 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6424 else if (op == EXEC_POINTER_ASSIGN)
6425 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6429 gfc_add_expr_to_block (&block, tmp);
6431 return gfc_finish_block (&block);