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)
88 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
96 || p->parent->ss->nested_ss == p->ss);
98 /* If we were in a nested loop, the next scalarized expression can be
99 on the parent ss' next pointer. Thus we should not take the next
100 pointer blindly, but rather go up one nest level as long as next
101 is the end of chain. */
103 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
113 /* Ensures the result of the expression as either a temporary variable
114 or a constant so that it can be used repeatedly. */
117 gfc_make_safe_expr (gfc_se * se)
121 if (CONSTANT_CLASS_P (se->expr))
124 /* We need a temporary for this result. */
125 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
126 gfc_add_modify (&se->pre, var, se->expr);
131 /* Return an expression which determines if a dummy parameter is present.
132 Also used for arguments to procedures with multiple entry points. */
135 gfc_conv_expr_present (gfc_symbol * sym)
139 gcc_assert (sym->attr.dummy);
141 decl = gfc_get_symbol_decl (sym);
142 if (TREE_CODE (decl) != PARM_DECL)
144 /* Array parameters use a temporary descriptor, we want the real
146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
147 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
148 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
151 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
152 fold_convert (TREE_TYPE (decl), null_pointer_node));
154 /* Fortran 2008 allows to pass null pointers and non-associated pointers
155 as actual argument to denote absent dummies. For array descriptors,
156 we thus also need to check the array descriptor. */
157 if (!sym->attr.pointer && !sym->attr.allocatable
158 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
159 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
162 tmp = build_fold_indirect_ref_loc (input_location, decl);
163 tmp = gfc_conv_array_data (tmp);
164 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
165 fold_convert (TREE_TYPE (tmp), null_pointer_node));
166 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
167 boolean_type_node, cond, tmp);
174 /* Converts a missing, dummy argument into a null or zero. */
177 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
182 present = gfc_conv_expr_present (arg->symtree->n.sym);
186 /* Create a temporary and convert it to the correct type. */
187 tmp = gfc_get_int_type (kind);
188 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
191 /* Test for a NULL value. */
192 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
193 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
194 tmp = gfc_evaluate_now (tmp, &se->pre);
195 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
199 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
201 build_zero_cst (TREE_TYPE (se->expr)));
202 tmp = gfc_evaluate_now (tmp, &se->pre);
206 if (ts.type == BT_CHARACTER)
208 tmp = build_int_cst (gfc_charlen_type_node, 0);
209 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
210 present, se->string_length, tmp);
211 tmp = gfc_evaluate_now (tmp, &se->pre);
212 se->string_length = tmp;
218 /* Get the character length of an expression, looking through gfc_refs
222 gfc_get_expr_charlen (gfc_expr *e)
227 gcc_assert (e->expr_type == EXPR_VARIABLE
228 && e->ts.type == BT_CHARACTER);
230 length = NULL; /* To silence compiler warning. */
232 if (is_subref_array (e) && e->ts.u.cl->length)
235 gfc_init_se (&tmpse, NULL);
236 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
237 e->ts.u.cl->backend_decl = tmpse.expr;
241 /* First candidate: if the variable is of type CHARACTER, the
242 expression's length could be the length of the character
244 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
245 length = e->symtree->n.sym->ts.u.cl->backend_decl;
247 /* Look through the reference chain for component references. */
248 for (r = e->ref; r; r = r->next)
253 if (r->u.c.component->ts.type == BT_CHARACTER)
254 length = r->u.c.component->ts.u.cl->backend_decl;
262 /* We should never got substring references here. These will be
263 broken down by the scalarizer. */
269 gcc_assert (length != NULL);
274 /* Return for an expression the backend decl of the coarray. */
277 get_tree_for_caf_expr (gfc_expr *expr)
279 tree caf_decl = NULL_TREE;
282 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
283 if (expr->symtree->n.sym->attr.codimension)
284 caf_decl = expr->symtree->n.sym->backend_decl;
286 for (ref = expr->ref; ref; ref = ref->next)
287 if (ref->type == REF_COMPONENT)
289 gfc_component *comp = ref->u.c.component;
290 if (comp->attr.pointer || comp->attr.allocatable)
291 caf_decl = NULL_TREE;
292 if (comp->attr.codimension)
293 caf_decl = comp->backend_decl;
296 gcc_assert (caf_decl != NULL_TREE);
301 /* For each character array constructor subexpression without a ts.u.cl->length,
302 replace it by its first element (if there aren't any elements, the length
303 should already be set to zero). */
306 flatten_array_ctors_without_strlen (gfc_expr* e)
308 gfc_actual_arglist* arg;
314 switch (e->expr_type)
318 flatten_array_ctors_without_strlen (e->value.op.op1);
319 flatten_array_ctors_without_strlen (e->value.op.op2);
323 /* TODO: Implement as with EXPR_FUNCTION when needed. */
327 for (arg = e->value.function.actual; arg; arg = arg->next)
328 flatten_array_ctors_without_strlen (arg->expr);
333 /* We've found what we're looking for. */
334 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
339 gcc_assert (e->value.constructor);
341 c = gfc_constructor_first (e->value.constructor);
345 flatten_array_ctors_without_strlen (new_expr);
346 gfc_replace_expr (e, new_expr);
350 /* Otherwise, fall through to handle constructor elements. */
352 for (c = gfc_constructor_first (e->value.constructor);
353 c; c = gfc_constructor_next (c))
354 flatten_array_ctors_without_strlen (c->expr);
364 /* Generate code to initialize a string length variable. Returns the
365 value. For array constructors, cl->length might be NULL and in this case,
366 the first element of the constructor is needed. expr is the original
367 expression so we can access it but can be NULL if this is not needed. */
370 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
374 gfc_init_se (&se, NULL);
378 && TREE_CODE (cl->backend_decl) == VAR_DECL)
381 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
382 "flatten" array constructors by taking their first element; all elements
383 should be the same length or a cl->length should be present. */
388 expr_flat = gfc_copy_expr (expr);
389 flatten_array_ctors_without_strlen (expr_flat);
390 gfc_resolve_expr (expr_flat);
392 gfc_conv_expr (&se, expr_flat);
393 gfc_add_block_to_block (pblock, &se.pre);
394 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
396 gfc_free_expr (expr_flat);
400 /* Convert cl->length. */
402 gcc_assert (cl->length);
404 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
405 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
406 se.expr, build_int_cst (gfc_charlen_type_node, 0));
407 gfc_add_block_to_block (pblock, &se.pre);
409 if (cl->backend_decl)
410 gfc_add_modify (pblock, cl->backend_decl, se.expr);
412 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
417 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
418 const char *name, locus *where)
427 type = gfc_get_character_type (kind, ref->u.ss.length);
428 type = build_pointer_type (type);
430 gfc_init_se (&start, se);
431 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
432 gfc_add_block_to_block (&se->pre, &start.pre);
434 if (integer_onep (start.expr))
435 gfc_conv_string_parameter (se);
440 /* Avoid multiple evaluation of substring start. */
441 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
442 start.expr = gfc_evaluate_now (start.expr, &se->pre);
444 /* Change the start of the string. */
445 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
448 tmp = build_fold_indirect_ref_loc (input_location,
450 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
451 se->expr = gfc_build_addr_expr (type, tmp);
454 /* Length = end + 1 - start. */
455 gfc_init_se (&end, se);
456 if (ref->u.ss.end == NULL)
457 end.expr = se->string_length;
460 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
461 gfc_add_block_to_block (&se->pre, &end.pre);
465 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
466 end.expr = gfc_evaluate_now (end.expr, &se->pre);
468 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
470 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
471 boolean_type_node, start.expr,
474 /* Check lower bound. */
475 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
477 build_int_cst (gfc_charlen_type_node, 1));
478 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
479 boolean_type_node, nonempty, fault);
481 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
482 "is less than one", name);
484 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
486 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
487 fold_convert (long_integer_type_node,
491 /* Check upper bound. */
492 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
493 end.expr, se->string_length);
494 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
495 boolean_type_node, nonempty, fault);
497 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
498 "exceeds string length (%%ld)", name);
500 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
501 "exceeds string length (%%ld)");
502 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
503 fold_convert (long_integer_type_node, end.expr),
504 fold_convert (long_integer_type_node,
509 /* If the start and end expressions are equal, the length is one. */
511 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
512 tmp = build_int_cst (gfc_charlen_type_node, 1);
515 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
516 end.expr, start.expr);
517 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
518 build_int_cst (gfc_charlen_type_node, 1), tmp);
519 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
520 tmp, build_int_cst (gfc_charlen_type_node, 0));
523 se->string_length = tmp;
527 /* Convert a derived type component reference. */
530 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
537 c = ref->u.c.component;
539 gcc_assert (c->backend_decl);
541 field = c->backend_decl;
542 gcc_assert (TREE_CODE (field) == FIELD_DECL);
545 /* Components can correspond to fields of different containing
546 types, as components are created without context, whereas
547 a concrete use of a component has the type of decl as context.
548 So, if the type doesn't match, we search the corresponding
549 FIELD_DECL in the parent type. To not waste too much time
550 we cache this result in norestrict_decl. */
552 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
554 tree f2 = c->norestrict_decl;
555 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
556 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
557 if (TREE_CODE (f2) == FIELD_DECL
558 && DECL_NAME (f2) == DECL_NAME (field))
561 c->norestrict_decl = f2;
564 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
565 decl, field, NULL_TREE);
569 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
571 tmp = c->ts.u.cl->backend_decl;
572 /* Components must always be constant length. */
573 gcc_assert (tmp && INTEGER_CST_P (tmp));
574 se->string_length = tmp;
577 if (((c->attr.pointer || c->attr.allocatable)
578 && (!c->attr.dimension && !c->attr.codimension)
579 && c->ts.type != BT_CHARACTER)
580 || c->attr.proc_pointer)
581 se->expr = build_fold_indirect_ref_loc (input_location,
586 /* This function deals with component references to components of the
587 parent type for derived type extensons. */
589 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
597 c = ref->u.c.component;
599 /* Return if the component is not in the parent type. */
600 for (cmp = dt->components; cmp; cmp = cmp->next)
601 if (strcmp (c->name, cmp->name) == 0)
604 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
605 parent.type = REF_COMPONENT;
608 parent.u.c.component = dt->components;
610 if (dt->backend_decl == NULL)
611 gfc_get_derived_type (dt);
613 /* Build the reference and call self. */
614 gfc_conv_component_ref (se, &parent);
615 parent.u.c.sym = dt->components->ts.u.derived;
616 parent.u.c.component = c;
617 conv_parent_component_references (se, &parent);
620 /* Return the contents of a variable. Also handles reference/pointer
621 variables (all Fortran pointer references are implicit). */
624 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
629 tree parent_decl = NULL_TREE;
632 bool alternate_entry;
635 sym = expr->symtree->n.sym;
639 gfc_ss_info *ss_info = ss->info;
641 /* Check that something hasn't gone horribly wrong. */
642 gcc_assert (ss != gfc_ss_terminator);
643 gcc_assert (ss_info->expr == expr);
645 /* A scalarized term. We already know the descriptor. */
646 se->expr = ss_info->data.array.descriptor;
647 se->string_length = ss_info->string_length;
648 for (ref = ss_info->data.array.ref; ref; ref = ref->next)
649 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
654 tree se_expr = NULL_TREE;
656 se->expr = gfc_get_symbol_decl (sym);
658 /* Deal with references to a parent results or entries by storing
659 the current_function_decl and moving to the parent_decl. */
660 return_value = sym->attr.function && sym->result == sym;
661 alternate_entry = sym->attr.function && sym->attr.entry
662 && sym->result == sym;
663 entry_master = sym->attr.result
664 && sym->ns->proc_name->attr.entry_master
665 && !gfc_return_by_reference (sym->ns->proc_name);
666 if (current_function_decl)
667 parent_decl = DECL_CONTEXT (current_function_decl);
669 if ((se->expr == parent_decl && return_value)
670 || (sym->ns && sym->ns->proc_name
672 && sym->ns->proc_name->backend_decl == parent_decl
673 && (alternate_entry || entry_master)))
678 /* Special case for assigning the return value of a function.
679 Self recursive functions must have an explicit return value. */
680 if (return_value && (se->expr == current_function_decl || parent_flag))
681 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
683 /* Similarly for alternate entry points. */
684 else if (alternate_entry
685 && (sym->ns->proc_name->backend_decl == current_function_decl
688 gfc_entry_list *el = NULL;
690 for (el = sym->ns->entries; el; el = el->next)
693 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
698 else if (entry_master
699 && (sym->ns->proc_name->backend_decl == current_function_decl
701 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
706 /* Procedure actual arguments. */
707 else if (sym->attr.flavor == FL_PROCEDURE
708 && se->expr != current_function_decl)
710 if (!sym->attr.dummy && !sym->attr.proc_pointer)
712 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
713 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
719 /* Dereference the expression, where needed. Since characters
720 are entirely different from other types, they are treated
722 if (sym->ts.type == BT_CHARACTER)
724 /* Dereference character pointer dummy arguments
726 if ((sym->attr.pointer || sym->attr.allocatable)
728 || sym->attr.function
729 || sym->attr.result))
730 se->expr = build_fold_indirect_ref_loc (input_location,
734 else if (!sym->attr.value)
736 /* Dereference non-character scalar dummy arguments. */
737 if (sym->attr.dummy && !sym->attr.dimension
738 && !(sym->attr.codimension && sym->attr.allocatable))
739 se->expr = build_fold_indirect_ref_loc (input_location,
742 /* Dereference scalar hidden result. */
743 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
744 && (sym->attr.function || sym->attr.result)
745 && !sym->attr.dimension && !sym->attr.pointer
746 && !sym->attr.always_explicit)
747 se->expr = build_fold_indirect_ref_loc (input_location,
750 /* Dereference non-character pointer variables.
751 These must be dummies, results, or scalars. */
752 if ((sym->attr.pointer || sym->attr.allocatable
753 || gfc_is_associate_pointer (sym))
755 || sym->attr.function
757 || (!sym->attr.dimension
758 && (!sym->attr.codimension || !sym->attr.allocatable))))
759 se->expr = build_fold_indirect_ref_loc (input_location,
766 /* For character variables, also get the length. */
767 if (sym->ts.type == BT_CHARACTER)
769 /* If the character length of an entry isn't set, get the length from
770 the master function instead. */
771 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
772 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
774 se->string_length = sym->ts.u.cl->backend_decl;
775 gcc_assert (se->string_length);
783 /* Return the descriptor if that's what we want and this is an array
784 section reference. */
785 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
787 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
788 /* Return the descriptor for array pointers and allocations. */
790 && ref->next == NULL && (se->descriptor_only))
793 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
794 /* Return a pointer to an element. */
798 if (ref->u.c.sym->attr.extension)
799 conv_parent_component_references (se, ref);
801 gfc_conv_component_ref (se, ref);
805 gfc_conv_substring (se, ref, expr->ts.kind,
806 expr->symtree->name, &expr->where);
815 /* Pointer assignment, allocation or pass by reference. Arrays are handled
817 if (se->want_pointer)
819 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
820 gfc_conv_string_parameter (se);
822 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
827 /* Unary ops are easy... Or they would be if ! was a valid op. */
830 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
835 gcc_assert (expr->ts.type != BT_CHARACTER);
836 /* Initialize the operand. */
837 gfc_init_se (&operand, se);
838 gfc_conv_expr_val (&operand, expr->value.op.op1);
839 gfc_add_block_to_block (&se->pre, &operand.pre);
841 type = gfc_typenode_for_spec (&expr->ts);
843 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
844 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
845 All other unary operators have an equivalent GIMPLE unary operator. */
846 if (code == TRUTH_NOT_EXPR)
847 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
848 build_int_cst (type, 0));
850 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
854 /* Expand power operator to optimal multiplications when a value is raised
855 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
856 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
857 Programming", 3rd Edition, 1998. */
859 /* This code is mostly duplicated from expand_powi in the backend.
860 We establish the "optimal power tree" lookup table with the defined size.
861 The items in the table are the exponents used to calculate the index
862 exponents. Any integer n less than the value can get an "addition chain",
863 with the first node being one. */
864 #define POWI_TABLE_SIZE 256
866 /* The table is from builtins.c. */
867 static const unsigned char powi_table[POWI_TABLE_SIZE] =
869 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
870 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
871 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
872 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
873 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
874 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
875 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
876 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
877 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
878 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
879 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
880 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
881 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
882 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
883 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
884 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
885 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
886 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
887 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
888 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
889 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
890 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
891 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
892 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
893 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
894 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
895 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
896 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
897 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
898 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
899 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
900 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
903 /* If n is larger than lookup table's max index, we use the "window
905 #define POWI_WINDOW_SIZE 3
907 /* Recursive function to expand the power operator. The temporary
908 values are put in tmpvar. The function returns tmpvar[1] ** n. */
910 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
917 if (n < POWI_TABLE_SIZE)
922 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
923 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
927 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
928 op0 = gfc_conv_powi (se, n - digit, tmpvar);
929 op1 = gfc_conv_powi (se, digit, tmpvar);
933 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
937 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
938 tmp = gfc_evaluate_now (tmp, &se->pre);
940 if (n < POWI_TABLE_SIZE)
947 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
948 return 1. Else return 0 and a call to runtime library functions
949 will have to be built. */
951 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
956 tree vartmp[POWI_TABLE_SIZE];
958 unsigned HOST_WIDE_INT n;
961 /* If exponent is too large, we won't expand it anyway, so don't bother
962 with large integer values. */
963 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
966 m = double_int_to_shwi (TREE_INT_CST (rhs));
967 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
968 of the asymmetric range of the integer type. */
969 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
971 type = TREE_TYPE (lhs);
972 sgn = tree_int_cst_sgn (rhs);
974 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
975 || optimize_size) && (m > 2 || m < -1))
981 se->expr = gfc_build_const (type, integer_one_node);
985 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
986 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
988 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
989 lhs, build_int_cst (TREE_TYPE (lhs), -1));
990 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
991 lhs, build_int_cst (TREE_TYPE (lhs), 1));
994 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
997 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
998 boolean_type_node, tmp, cond);
999 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1000 tmp, build_int_cst (type, 1),
1001 build_int_cst (type, 0));
1005 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1006 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
1007 build_int_cst (type, -1),
1008 build_int_cst (type, 0));
1009 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1010 cond, build_int_cst (type, 1), tmp);
1014 memset (vartmp, 0, sizeof (vartmp));
1018 tmp = gfc_build_const (type, integer_one_node);
1019 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1023 se->expr = gfc_conv_powi (se, n, vartmp);
1029 /* Power op (**). Constant integer exponent has special handling. */
1032 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1034 tree gfc_int4_type_node;
1037 int res_ikind_1, res_ikind_2;
1042 gfc_init_se (&lse, se);
1043 gfc_conv_expr_val (&lse, expr->value.op.op1);
1044 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1045 gfc_add_block_to_block (&se->pre, &lse.pre);
1047 gfc_init_se (&rse, se);
1048 gfc_conv_expr_val (&rse, expr->value.op.op2);
1049 gfc_add_block_to_block (&se->pre, &rse.pre);
1051 if (expr->value.op.op2->ts.type == BT_INTEGER
1052 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1053 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1056 gfc_int4_type_node = gfc_get_int_type (4);
1058 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1059 library routine. But in the end, we have to convert the result back
1060 if this case applies -- with res_ikind_K, we keep track whether operand K
1061 falls into this case. */
1065 kind = expr->value.op.op1->ts.kind;
1066 switch (expr->value.op.op2->ts.type)
1069 ikind = expr->value.op.op2->ts.kind;
1074 rse.expr = convert (gfc_int4_type_node, rse.expr);
1075 res_ikind_2 = ikind;
1097 if (expr->value.op.op1->ts.type == BT_INTEGER)
1099 lse.expr = convert (gfc_int4_type_node, lse.expr);
1126 switch (expr->value.op.op1->ts.type)
1129 if (kind == 3) /* Case 16 was not handled properly above. */
1131 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1135 /* Use builtins for real ** int4. */
1141 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
1145 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1149 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1153 /* Use the __builtin_powil() only if real(kind=16) is
1154 actually the C long double type. */
1155 if (!gfc_real16_is_float128)
1156 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1164 /* If we don't have a good builtin for this, go for the
1165 library function. */
1167 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1171 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1180 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1184 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1192 se->expr = build_call_expr_loc (input_location,
1193 fndecl, 2, lse.expr, rse.expr);
1195 /* Convert the result back if it is of wrong integer kind. */
1196 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1198 /* We want the maximum of both operand kinds as result. */
1199 if (res_ikind_1 < res_ikind_2)
1200 res_ikind_1 = res_ikind_2;
1201 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1206 /* Generate code to allocate a string temporary. */
1209 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1214 if (gfc_can_put_var_on_stack (len))
1216 /* Create a temporary variable to hold the result. */
1217 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1218 gfc_charlen_type_node, len,
1219 build_int_cst (gfc_charlen_type_node, 1));
1220 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1222 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1223 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1225 tmp = build_array_type (TREE_TYPE (type), tmp);
1227 var = gfc_create_var (tmp, "str");
1228 var = gfc_build_addr_expr (type, var);
1232 /* Allocate a temporary to hold the result. */
1233 var = gfc_create_var (type, "pstr");
1234 tmp = gfc_call_malloc (&se->pre, type,
1235 fold_build2_loc (input_location, MULT_EXPR,
1236 TREE_TYPE (len), len,
1237 fold_convert (TREE_TYPE (len),
1238 TYPE_SIZE (type))));
1239 gfc_add_modify (&se->pre, var, tmp);
1241 /* Free the temporary afterwards. */
1242 tmp = gfc_call_free (convert (pvoid_type_node, var));
1243 gfc_add_expr_to_block (&se->post, tmp);
1250 /* Handle a string concatenation operation. A temporary will be allocated to
1254 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1257 tree len, type, var, tmp, fndecl;
1259 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1260 && expr->value.op.op2->ts.type == BT_CHARACTER);
1261 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1263 gfc_init_se (&lse, se);
1264 gfc_conv_expr (&lse, expr->value.op.op1);
1265 gfc_conv_string_parameter (&lse);
1266 gfc_init_se (&rse, se);
1267 gfc_conv_expr (&rse, expr->value.op.op2);
1268 gfc_conv_string_parameter (&rse);
1270 gfc_add_block_to_block (&se->pre, &lse.pre);
1271 gfc_add_block_to_block (&se->pre, &rse.pre);
1273 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1274 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1275 if (len == NULL_TREE)
1277 len = fold_build2_loc (input_location, PLUS_EXPR,
1278 TREE_TYPE (lse.string_length),
1279 lse.string_length, rse.string_length);
1282 type = build_pointer_type (type);
1284 var = gfc_conv_string_tmp (se, type, len);
1286 /* Do the actual concatenation. */
1287 if (expr->ts.kind == 1)
1288 fndecl = gfor_fndecl_concat_string;
1289 else if (expr->ts.kind == 4)
1290 fndecl = gfor_fndecl_concat_string_char4;
1294 tmp = build_call_expr_loc (input_location,
1295 fndecl, 6, len, var, lse.string_length, lse.expr,
1296 rse.string_length, rse.expr);
1297 gfc_add_expr_to_block (&se->pre, tmp);
1299 /* Add the cleanup for the operands. */
1300 gfc_add_block_to_block (&se->pre, &rse.post);
1301 gfc_add_block_to_block (&se->pre, &lse.post);
1304 se->string_length = len;
1307 /* Translates an op expression. Common (binary) cases are handled by this
1308 function, others are passed on. Recursion is used in either case.
1309 We use the fact that (op1.ts == op2.ts) (except for the power
1311 Operators need no special handling for scalarized expressions as long as
1312 they call gfc_conv_simple_val to get their operands.
1313 Character strings get special handling. */
1316 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1318 enum tree_code code;
1327 switch (expr->value.op.op)
1329 case INTRINSIC_PARENTHESES:
1330 if ((expr->ts.type == BT_REAL
1331 || expr->ts.type == BT_COMPLEX)
1332 && gfc_option.flag_protect_parens)
1334 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1335 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1340 case INTRINSIC_UPLUS:
1341 gfc_conv_expr (se, expr->value.op.op1);
1344 case INTRINSIC_UMINUS:
1345 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1349 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1352 case INTRINSIC_PLUS:
1356 case INTRINSIC_MINUS:
1360 case INTRINSIC_TIMES:
1364 case INTRINSIC_DIVIDE:
1365 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1366 an integer, we must round towards zero, so we use a
1368 if (expr->ts.type == BT_INTEGER)
1369 code = TRUNC_DIV_EXPR;
1374 case INTRINSIC_POWER:
1375 gfc_conv_power_op (se, expr);
1378 case INTRINSIC_CONCAT:
1379 gfc_conv_concat_op (se, expr);
1383 code = TRUTH_ANDIF_EXPR;
1388 code = TRUTH_ORIF_EXPR;
1392 /* EQV and NEQV only work on logicals, but since we represent them
1393 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1395 case INTRINSIC_EQ_OS:
1403 case INTRINSIC_NE_OS:
1404 case INTRINSIC_NEQV:
1411 case INTRINSIC_GT_OS:
1418 case INTRINSIC_GE_OS:
1425 case INTRINSIC_LT_OS:
1432 case INTRINSIC_LE_OS:
1438 case INTRINSIC_USER:
1439 case INTRINSIC_ASSIGN:
1440 /* These should be converted into function calls by the frontend. */
1444 fatal_error ("Unknown intrinsic op");
1448 /* The only exception to this is **, which is handled separately anyway. */
1449 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1451 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1455 gfc_init_se (&lse, se);
1456 gfc_conv_expr (&lse, expr->value.op.op1);
1457 gfc_add_block_to_block (&se->pre, &lse.pre);
1460 gfc_init_se (&rse, se);
1461 gfc_conv_expr (&rse, expr->value.op.op2);
1462 gfc_add_block_to_block (&se->pre, &rse.pre);
1466 gfc_conv_string_parameter (&lse);
1467 gfc_conv_string_parameter (&rse);
1469 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1470 rse.string_length, rse.expr,
1471 expr->value.op.op1->ts.kind,
1473 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1474 gfc_add_block_to_block (&lse.post, &rse.post);
1477 type = gfc_typenode_for_spec (&expr->ts);
1481 /* The result of logical ops is always boolean_type_node. */
1482 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1483 lse.expr, rse.expr);
1484 se->expr = convert (type, tmp);
1487 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1489 /* Add the post blocks. */
1490 gfc_add_block_to_block (&se->post, &rse.post);
1491 gfc_add_block_to_block (&se->post, &lse.post);
1494 /* If a string's length is one, we convert it to a single character. */
1497 gfc_string_to_single_character (tree len, tree str, int kind)
1500 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1501 || !POINTER_TYPE_P (TREE_TYPE (str)))
1504 if (TREE_INT_CST_LOW (len) == 1)
1506 str = fold_convert (gfc_get_pchar_type (kind), str);
1507 return build_fold_indirect_ref_loc (input_location, str);
1511 && TREE_CODE (str) == ADDR_EXPR
1512 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1513 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1514 && array_ref_low_bound (TREE_OPERAND (str, 0))
1515 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1516 && TREE_INT_CST_LOW (len) > 1
1517 && TREE_INT_CST_LOW (len)
1518 == (unsigned HOST_WIDE_INT)
1519 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1521 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1522 ret = build_fold_indirect_ref_loc (input_location, ret);
1523 if (TREE_CODE (ret) == INTEGER_CST)
1525 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1526 int i, length = TREE_STRING_LENGTH (string_cst);
1527 const char *ptr = TREE_STRING_POINTER (string_cst);
1529 for (i = 1; i < length; i++)
1542 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1545 if (sym->backend_decl)
1547 /* This becomes the nominal_type in
1548 function.c:assign_parm_find_data_types. */
1549 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1550 /* This becomes the passed_type in
1551 function.c:assign_parm_find_data_types. C promotes char to
1552 integer for argument passing. */
1553 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1555 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1560 /* If we have a constant character expression, make it into an
1562 if ((*expr)->expr_type == EXPR_CONSTANT)
1567 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1568 (int)(*expr)->value.character.string[0]);
1569 if ((*expr)->ts.kind != gfc_c_int_kind)
1571 /* The expr needs to be compatible with a C int. If the
1572 conversion fails, then the 2 causes an ICE. */
1573 ts.type = BT_INTEGER;
1574 ts.kind = gfc_c_int_kind;
1575 gfc_convert_type (*expr, &ts, 2);
1578 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1580 if ((*expr)->ref == NULL)
1582 se->expr = gfc_string_to_single_character
1583 (build_int_cst (integer_type_node, 1),
1584 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1586 ((*expr)->symtree->n.sym)),
1591 gfc_conv_variable (se, *expr);
1592 se->expr = gfc_string_to_single_character
1593 (build_int_cst (integer_type_node, 1),
1594 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1602 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1603 if STR is a string literal, otherwise return -1. */
1606 gfc_optimize_len_trim (tree len, tree str, int kind)
1609 && TREE_CODE (str) == ADDR_EXPR
1610 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1611 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1612 && array_ref_low_bound (TREE_OPERAND (str, 0))
1613 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1614 && TREE_INT_CST_LOW (len) >= 1
1615 && TREE_INT_CST_LOW (len)
1616 == (unsigned HOST_WIDE_INT)
1617 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1619 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1620 folded = build_fold_indirect_ref_loc (input_location, folded);
1621 if (TREE_CODE (folded) == INTEGER_CST)
1623 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1624 int length = TREE_STRING_LENGTH (string_cst);
1625 const char *ptr = TREE_STRING_POINTER (string_cst);
1627 for (; length > 0; length--)
1628 if (ptr[length - 1] != ' ')
1637 /* Compare two strings. If they are all single characters, the result is the
1638 subtraction of them. Otherwise, we build a library call. */
1641 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1642 enum tree_code code)
1648 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1649 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1651 sc1 = gfc_string_to_single_character (len1, str1, kind);
1652 sc2 = gfc_string_to_single_character (len2, str2, kind);
1654 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1656 /* Deal with single character specially. */
1657 sc1 = fold_convert (integer_type_node, sc1);
1658 sc2 = fold_convert (integer_type_node, sc2);
1659 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1663 if ((code == EQ_EXPR || code == NE_EXPR)
1665 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1667 /* If one string is a string literal with LEN_TRIM longer
1668 than the length of the second string, the strings
1670 int len = gfc_optimize_len_trim (len1, str1, kind);
1671 if (len > 0 && compare_tree_int (len2, len) < 0)
1672 return integer_one_node;
1673 len = gfc_optimize_len_trim (len2, str2, kind);
1674 if (len > 0 && compare_tree_int (len1, len) < 0)
1675 return integer_one_node;
1678 /* Build a call for the comparison. */
1680 fndecl = gfor_fndecl_compare_string;
1682 fndecl = gfor_fndecl_compare_string_char4;
1686 return build_call_expr_loc (input_location, fndecl, 4,
1687 len1, str1, len2, str2);
1691 /* Return the backend_decl for a procedure pointer component. */
1694 get_proc_ptr_comp (gfc_expr *e)
1700 gfc_init_se (&comp_se, NULL);
1701 e2 = gfc_copy_expr (e);
1702 /* We have to restore the expr type later so that gfc_free_expr frees
1703 the exact same thing that was allocated.
1704 TODO: This is ugly. */
1705 old_type = e2->expr_type;
1706 e2->expr_type = EXPR_VARIABLE;
1707 gfc_conv_expr (&comp_se, e2);
1708 e2->expr_type = old_type;
1710 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1715 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1719 if (gfc_is_proc_ptr_comp (expr, NULL))
1720 tmp = get_proc_ptr_comp (expr);
1721 else if (sym->attr.dummy)
1723 tmp = gfc_get_symbol_decl (sym);
1724 if (sym->attr.proc_pointer)
1725 tmp = build_fold_indirect_ref_loc (input_location,
1727 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1728 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1732 if (!sym->backend_decl)
1733 sym->backend_decl = gfc_get_extern_function_decl (sym);
1735 tmp = sym->backend_decl;
1737 if (sym->attr.cray_pointee)
1739 /* TODO - make the cray pointee a pointer to a procedure,
1740 assign the pointer to it and use it for the call. This
1742 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1743 gfc_get_symbol_decl (sym->cp_pointer));
1744 tmp = gfc_evaluate_now (tmp, &se->pre);
1747 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1749 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1750 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1757 /* Initialize MAPPING. */
1760 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1762 mapping->syms = NULL;
1763 mapping->charlens = NULL;
1767 /* Free all memory held by MAPPING (but not MAPPING itself). */
1770 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1772 gfc_interface_sym_mapping *sym;
1773 gfc_interface_sym_mapping *nextsym;
1775 gfc_charlen *nextcl;
1777 for (sym = mapping->syms; sym; sym = nextsym)
1779 nextsym = sym->next;
1780 sym->new_sym->n.sym->formal = NULL;
1781 gfc_free_symbol (sym->new_sym->n.sym);
1782 gfc_free_expr (sym->expr);
1783 free (sym->new_sym);
1786 for (cl = mapping->charlens; cl; cl = nextcl)
1789 gfc_free_expr (cl->length);
1795 /* Return a copy of gfc_charlen CL. Add the returned structure to
1796 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1798 static gfc_charlen *
1799 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1802 gfc_charlen *new_charlen;
1804 new_charlen = gfc_get_charlen ();
1805 new_charlen->next = mapping->charlens;
1806 new_charlen->length = gfc_copy_expr (cl->length);
1808 mapping->charlens = new_charlen;
1813 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1814 array variable that can be used as the actual argument for dummy
1815 argument SYM. Add any initialization code to BLOCK. PACKED is as
1816 for gfc_get_nodesc_array_type and DATA points to the first element
1817 in the passed array. */
1820 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1821 gfc_packed packed, tree data)
1826 type = gfc_typenode_for_spec (&sym->ts);
1827 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1828 !sym->attr.target && !sym->attr.pointer
1829 && !sym->attr.proc_pointer);
1831 var = gfc_create_var (type, "ifm");
1832 gfc_add_modify (block, var, fold_convert (type, data));
1838 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1839 and offset of descriptorless array type TYPE given that it has the same
1840 size as DESC. Add any set-up code to BLOCK. */
1843 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1850 offset = gfc_index_zero_node;
1851 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1853 dim = gfc_rank_cst[n];
1854 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1855 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1857 GFC_TYPE_ARRAY_LBOUND (type, n)
1858 = gfc_conv_descriptor_lbound_get (desc, dim);
1859 GFC_TYPE_ARRAY_UBOUND (type, n)
1860 = gfc_conv_descriptor_ubound_get (desc, dim);
1862 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1864 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1865 gfc_array_index_type,
1866 gfc_conv_descriptor_ubound_get (desc, dim),
1867 gfc_conv_descriptor_lbound_get (desc, dim));
1868 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1869 gfc_array_index_type,
1870 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1871 tmp = gfc_evaluate_now (tmp, block);
1872 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1874 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1875 GFC_TYPE_ARRAY_LBOUND (type, n),
1876 GFC_TYPE_ARRAY_STRIDE (type, n));
1877 offset = fold_build2_loc (input_location, MINUS_EXPR,
1878 gfc_array_index_type, offset, tmp);
1880 offset = gfc_evaluate_now (offset, block);
1881 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1885 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1886 in SE. The caller may still use se->expr and se->string_length after
1887 calling this function. */
1890 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1891 gfc_symbol * sym, gfc_se * se,
1894 gfc_interface_sym_mapping *sm;
1898 gfc_symbol *new_sym;
1900 gfc_symtree *new_symtree;
1902 /* Create a new symbol to represent the actual argument. */
1903 new_sym = gfc_new_symbol (sym->name, NULL);
1904 new_sym->ts = sym->ts;
1905 new_sym->as = gfc_copy_array_spec (sym->as);
1906 new_sym->attr.referenced = 1;
1907 new_sym->attr.dimension = sym->attr.dimension;
1908 new_sym->attr.contiguous = sym->attr.contiguous;
1909 new_sym->attr.codimension = sym->attr.codimension;
1910 new_sym->attr.pointer = sym->attr.pointer;
1911 new_sym->attr.allocatable = sym->attr.allocatable;
1912 new_sym->attr.flavor = sym->attr.flavor;
1913 new_sym->attr.function = sym->attr.function;
1915 /* Ensure that the interface is available and that
1916 descriptors are passed for array actual arguments. */
1917 if (sym->attr.flavor == FL_PROCEDURE)
1919 new_sym->formal = expr->symtree->n.sym->formal;
1920 new_sym->attr.always_explicit
1921 = expr->symtree->n.sym->attr.always_explicit;
1924 /* Create a fake symtree for it. */
1926 new_symtree = gfc_new_symtree (&root, sym->name);
1927 new_symtree->n.sym = new_sym;
1928 gcc_assert (new_symtree == root);
1930 /* Create a dummy->actual mapping. */
1931 sm = XCNEW (gfc_interface_sym_mapping);
1932 sm->next = mapping->syms;
1934 sm->new_sym = new_symtree;
1935 sm->expr = gfc_copy_expr (expr);
1938 /* Stabilize the argument's value. */
1939 if (!sym->attr.function && se)
1940 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1942 if (sym->ts.type == BT_CHARACTER)
1944 /* Create a copy of the dummy argument's length. */
1945 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1946 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1948 /* If the length is specified as "*", record the length that
1949 the caller is passing. We should use the callee's length
1950 in all other cases. */
1951 if (!new_sym->ts.u.cl->length && se)
1953 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1954 new_sym->ts.u.cl->backend_decl = se->string_length;
1961 /* Use the passed value as-is if the argument is a function. */
1962 if (sym->attr.flavor == FL_PROCEDURE)
1965 /* If the argument is either a string or a pointer to a string,
1966 convert it to a boundless character type. */
1967 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1969 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1970 tmp = build_pointer_type (tmp);
1971 if (sym->attr.pointer)
1972 value = build_fold_indirect_ref_loc (input_location,
1976 value = fold_convert (tmp, value);
1979 /* If the argument is a scalar, a pointer to an array or an allocatable,
1981 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1982 value = build_fold_indirect_ref_loc (input_location,
1985 /* For character(*), use the actual argument's descriptor. */
1986 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1987 value = build_fold_indirect_ref_loc (input_location,
1990 /* If the argument is an array descriptor, use it to determine
1991 information about the actual argument's shape. */
1992 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1993 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1995 /* Get the actual argument's descriptor. */
1996 desc = build_fold_indirect_ref_loc (input_location,
1999 /* Create the replacement variable. */
2000 tmp = gfc_conv_descriptor_data_get (desc);
2001 value = gfc_get_interface_mapping_array (&se->pre, sym,
2004 /* Use DESC to work out the upper bounds, strides and offset. */
2005 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
2008 /* Otherwise we have a packed array. */
2009 value = gfc_get_interface_mapping_array (&se->pre, sym,
2010 PACKED_FULL, se->expr);
2012 new_sym->backend_decl = value;
2016 /* Called once all dummy argument mappings have been added to MAPPING,
2017 but before the mapping is used to evaluate expressions. Pre-evaluate
2018 the length of each argument, adding any initialization code to PRE and
2019 any finalization code to POST. */
2022 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2023 stmtblock_t * pre, stmtblock_t * post)
2025 gfc_interface_sym_mapping *sym;
2029 for (sym = mapping->syms; sym; sym = sym->next)
2030 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2031 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2033 expr = sym->new_sym->n.sym->ts.u.cl->length;
2034 gfc_apply_interface_mapping_to_expr (mapping, expr);
2035 gfc_init_se (&se, NULL);
2036 gfc_conv_expr (&se, expr);
2037 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2038 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2039 gfc_add_block_to_block (pre, &se.pre);
2040 gfc_add_block_to_block (post, &se.post);
2042 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2047 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2051 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2052 gfc_constructor_base base)
2055 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2057 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2060 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2061 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2062 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2068 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2072 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2077 for (; ref; ref = ref->next)
2081 for (n = 0; n < ref->u.ar.dimen; n++)
2083 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2084 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2085 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2087 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2094 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2095 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2101 /* Convert intrinsic function calls into result expressions. */
2104 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2112 arg1 = expr->value.function.actual->expr;
2113 if (expr->value.function.actual->next)
2114 arg2 = expr->value.function.actual->next->expr;
2118 sym = arg1->symtree->n.sym;
2120 if (sym->attr.dummy)
2125 switch (expr->value.function.isym->id)
2128 /* TODO figure out why this condition is necessary. */
2129 if (sym->attr.function
2130 && (arg1->ts.u.cl->length == NULL
2131 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2132 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2135 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2139 if (!sym->as || sym->as->rank == 0)
2142 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2144 dup = mpz_get_si (arg2->value.integer);
2149 dup = sym->as->rank;
2153 for (; d < dup; d++)
2157 if (!sym->as->upper[d] || !sym->as->lower[d])
2159 gfc_free_expr (new_expr);
2163 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2164 gfc_get_int_expr (gfc_default_integer_kind,
2166 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2168 new_expr = gfc_multiply (new_expr, tmp);
2174 case GFC_ISYM_LBOUND:
2175 case GFC_ISYM_UBOUND:
2176 /* TODO These implementations of lbound and ubound do not limit if
2177 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2179 if (!sym->as || sym->as->rank == 0)
2182 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2183 d = mpz_get_si (arg2->value.integer) - 1;
2185 /* TODO: If the need arises, this could produce an array of
2189 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2191 if (sym->as->lower[d])
2192 new_expr = gfc_copy_expr (sym->as->lower[d]);
2196 if (sym->as->upper[d])
2197 new_expr = gfc_copy_expr (sym->as->upper[d]);
2205 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2209 gfc_replace_expr (expr, new_expr);
2215 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2216 gfc_interface_mapping * mapping)
2218 gfc_formal_arglist *f;
2219 gfc_actual_arglist *actual;
2221 actual = expr->value.function.actual;
2222 f = map_expr->symtree->n.sym->formal;
2224 for (; f && actual; f = f->next, actual = actual->next)
2229 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2232 if (map_expr->symtree->n.sym->attr.dimension)
2237 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2239 for (d = 0; d < as->rank; d++)
2241 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2242 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2245 expr->value.function.esym->as = as;
2248 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2250 expr->value.function.esym->ts.u.cl->length
2251 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2253 gfc_apply_interface_mapping_to_expr (mapping,
2254 expr->value.function.esym->ts.u.cl->length);
2259 /* EXPR is a copy of an expression that appeared in the interface
2260 associated with MAPPING. Walk it recursively looking for references to
2261 dummy arguments that MAPPING maps to actual arguments. Replace each such
2262 reference with a reference to the associated actual argument. */
2265 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2268 gfc_interface_sym_mapping *sym;
2269 gfc_actual_arglist *actual;
2274 /* Copying an expression does not copy its length, so do that here. */
2275 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2277 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2278 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2281 /* Apply the mapping to any references. */
2282 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2284 /* ...and to the expression's symbol, if it has one. */
2285 /* TODO Find out why the condition on expr->symtree had to be moved into
2286 the loop rather than being outside it, as originally. */
2287 for (sym = mapping->syms; sym; sym = sym->next)
2288 if (expr->symtree && sym->old == expr->symtree->n.sym)
2290 if (sym->new_sym->n.sym->backend_decl)
2291 expr->symtree = sym->new_sym;
2293 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2294 /* Replace base type for polymorphic arguments. */
2295 if (expr->ref && expr->ref->type == REF_COMPONENT
2296 && sym->expr && sym->expr->ts.type == BT_CLASS)
2297 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2300 /* ...and to subexpressions in expr->value. */
2301 switch (expr->expr_type)
2306 case EXPR_SUBSTRING:
2310 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2311 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2315 for (actual = expr->value.function.actual; actual; actual = actual->next)
2316 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2318 if (expr->value.function.esym == NULL
2319 && expr->value.function.isym != NULL
2320 && expr->value.function.actual->expr->symtree
2321 && gfc_map_intrinsic_function (expr, mapping))
2324 for (sym = mapping->syms; sym; sym = sym->next)
2325 if (sym->old == expr->value.function.esym)
2327 expr->value.function.esym = sym->new_sym->n.sym;
2328 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2329 expr->value.function.esym->result = sym->new_sym->n.sym;
2334 case EXPR_STRUCTURE:
2335 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2348 /* Evaluate interface expression EXPR using MAPPING. Store the result
2352 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2353 gfc_se * se, gfc_expr * expr)
2355 expr = gfc_copy_expr (expr);
2356 gfc_apply_interface_mapping_to_expr (mapping, expr);
2357 gfc_conv_expr (se, expr);
2358 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2359 gfc_free_expr (expr);
2363 /* Returns a reference to a temporary array into which a component of
2364 an actual argument derived type array is copied and then returned
2365 after the function call. */
2367 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2368 sym_intent intent, bool formal_ptr)
2376 gfc_array_info *info;
2386 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2388 gfc_init_se (&lse, NULL);
2389 gfc_init_se (&rse, NULL);
2391 /* Walk the argument expression. */
2392 rss = gfc_walk_expr (expr);
2394 gcc_assert (rss != gfc_ss_terminator);
2396 /* Initialize the scalarizer. */
2397 gfc_init_loopinfo (&loop);
2398 gfc_add_ss_to_loop (&loop, rss);
2400 /* Calculate the bounds of the scalarization. */
2401 gfc_conv_ss_startstride (&loop);
2403 /* Build an ss for the temporary. */
2404 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2405 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2407 base_type = gfc_typenode_for_spec (&expr->ts);
2408 if (GFC_ARRAY_TYPE_P (base_type)
2409 || GFC_DESCRIPTOR_TYPE_P (base_type))
2410 base_type = gfc_get_element_type (base_type);
2412 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2413 ? expr->ts.u.cl->backend_decl
2417 parmse->string_length = loop.temp_ss->info->string_length;
2419 /* Associate the SS with the loop. */
2420 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2422 /* Setup the scalarizing loops. */
2423 gfc_conv_loop_setup (&loop, &expr->where);
2425 /* Pass the temporary descriptor back to the caller. */
2426 info = &loop.temp_ss->info->data.array;
2427 parmse->expr = info->descriptor;
2429 /* Setup the gfc_se structures. */
2430 gfc_copy_loopinfo_to_se (&lse, &loop);
2431 gfc_copy_loopinfo_to_se (&rse, &loop);
2434 lse.ss = loop.temp_ss;
2435 gfc_mark_ss_chain_used (rss, 1);
2436 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2438 /* Start the scalarized loop body. */
2439 gfc_start_scalarized_body (&loop, &body);
2441 /* Translate the expression. */
2442 gfc_conv_expr (&rse, expr);
2444 gfc_conv_tmp_array_ref (&lse);
2446 if (intent != INTENT_OUT)
2448 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2449 gfc_add_expr_to_block (&body, tmp);
2450 gcc_assert (rse.ss == gfc_ss_terminator);
2451 gfc_trans_scalarizing_loops (&loop, &body);
2455 /* Make sure that the temporary declaration survives by merging
2456 all the loop declarations into the current context. */
2457 for (n = 0; n < loop.dimen; n++)
2459 gfc_merge_block_scope (&body);
2460 body = loop.code[loop.order[n]];
2462 gfc_merge_block_scope (&body);
2465 /* Add the post block after the second loop, so that any
2466 freeing of allocated memory is done at the right time. */
2467 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2469 /**********Copy the temporary back again.*********/
2471 gfc_init_se (&lse, NULL);
2472 gfc_init_se (&rse, NULL);
2474 /* Walk the argument expression. */
2475 lss = gfc_walk_expr (expr);
2476 rse.ss = loop.temp_ss;
2479 /* Initialize the scalarizer. */
2480 gfc_init_loopinfo (&loop2);
2481 gfc_add_ss_to_loop (&loop2, lss);
2483 /* Calculate the bounds of the scalarization. */
2484 gfc_conv_ss_startstride (&loop2);
2486 /* Setup the scalarizing loops. */
2487 gfc_conv_loop_setup (&loop2, &expr->where);
2489 gfc_copy_loopinfo_to_se (&lse, &loop2);
2490 gfc_copy_loopinfo_to_se (&rse, &loop2);
2492 gfc_mark_ss_chain_used (lss, 1);
2493 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2495 /* Declare the variable to hold the temporary offset and start the
2496 scalarized loop body. */
2497 offset = gfc_create_var (gfc_array_index_type, NULL);
2498 gfc_start_scalarized_body (&loop2, &body);
2500 /* Build the offsets for the temporary from the loop variables. The
2501 temporary array has lbounds of zero and strides of one in all
2502 dimensions, so this is very simple. The offset is only computed
2503 outside the innermost loop, so the overall transfer could be
2504 optimized further. */
2505 info = &rse.ss->info->data.array;
2506 dimen = rse.ss->dimen;
2508 tmp_index = gfc_index_zero_node;
2509 for (n = dimen - 1; n > 0; n--)
2512 tmp = rse.loop->loopvar[n];
2513 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2514 tmp, rse.loop->from[n]);
2515 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2518 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2519 gfc_array_index_type,
2520 rse.loop->to[n-1], rse.loop->from[n-1]);
2521 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2522 gfc_array_index_type,
2523 tmp_str, gfc_index_one_node);
2525 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2526 gfc_array_index_type, tmp, tmp_str);
2529 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2530 gfc_array_index_type,
2531 tmp_index, rse.loop->from[0]);
2532 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2534 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2535 gfc_array_index_type,
2536 rse.loop->loopvar[0], offset);
2538 /* Now use the offset for the reference. */
2539 tmp = build_fold_indirect_ref_loc (input_location,
2541 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2543 if (expr->ts.type == BT_CHARACTER)
2544 rse.string_length = expr->ts.u.cl->backend_decl;
2546 gfc_conv_expr (&lse, expr);
2548 gcc_assert (lse.ss == gfc_ss_terminator);
2550 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2551 gfc_add_expr_to_block (&body, tmp);
2553 /* Generate the copying loops. */
2554 gfc_trans_scalarizing_loops (&loop2, &body);
2556 /* Wrap the whole thing up by adding the second loop to the post-block
2557 and following it by the post-block of the first loop. In this way,
2558 if the temporary needs freeing, it is done after use! */
2559 if (intent != INTENT_IN)
2561 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2562 gfc_add_block_to_block (&parmse->post, &loop2.post);
2565 gfc_add_block_to_block (&parmse->post, &loop.post);
2567 gfc_cleanup_loop (&loop);
2568 gfc_cleanup_loop (&loop2);
2570 /* Pass the string length to the argument expression. */
2571 if (expr->ts.type == BT_CHARACTER)
2572 parmse->string_length = expr->ts.u.cl->backend_decl;
2574 /* Determine the offset for pointer formal arguments and set the
2578 size = gfc_index_one_node;
2579 offset = gfc_index_zero_node;
2580 for (n = 0; n < dimen; n++)
2582 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2584 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2585 gfc_array_index_type, tmp,
2586 gfc_index_one_node);
2587 gfc_conv_descriptor_ubound_set (&parmse->pre,
2591 gfc_conv_descriptor_lbound_set (&parmse->pre,
2594 gfc_index_one_node);
2595 size = gfc_evaluate_now (size, &parmse->pre);
2596 offset = fold_build2_loc (input_location, MINUS_EXPR,
2597 gfc_array_index_type,
2599 offset = gfc_evaluate_now (offset, &parmse->pre);
2600 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2601 gfc_array_index_type,
2602 rse.loop->to[n], rse.loop->from[n]);
2603 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2604 gfc_array_index_type,
2605 tmp, gfc_index_one_node);
2606 size = fold_build2_loc (input_location, MULT_EXPR,
2607 gfc_array_index_type, size, tmp);
2610 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2614 /* We want either the address for the data or the address of the descriptor,
2615 depending on the mode of passing array arguments. */
2617 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2619 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2625 /* Generate the code for argument list functions. */
2628 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2630 /* Pass by value for g77 %VAL(arg), pass the address
2631 indirectly for %LOC, else by reference. Thus %REF
2632 is a "do-nothing" and %LOC is the same as an F95
2634 if (strncmp (name, "%VAL", 4) == 0)
2635 gfc_conv_expr (se, expr);
2636 else if (strncmp (name, "%LOC", 4) == 0)
2638 gfc_conv_expr_reference (se, expr);
2639 se->expr = gfc_build_addr_expr (NULL, se->expr);
2641 else if (strncmp (name, "%REF", 4) == 0)
2642 gfc_conv_expr_reference (se, expr);
2644 gfc_error ("Unknown argument list function at %L", &expr->where);
2648 /* Takes a derived type expression and returns the address of a temporary
2649 class object of the 'declared' type. */
2651 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2652 gfc_typespec class_ts)
2656 gfc_symbol *declared = class_ts.u.derived;
2662 /* The derived type needs to be converted to a temporary
2664 tmp = gfc_typenode_for_spec (&class_ts);
2665 var = gfc_create_var (tmp, "class");
2668 cmp = gfc_find_component (declared, "_vptr", true, true);
2669 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2670 TREE_TYPE (cmp->backend_decl),
2671 var, cmp->backend_decl, NULL_TREE);
2673 /* Remember the vtab corresponds to the derived type
2674 not to the class declared type. */
2675 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2677 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2678 gfc_add_modify (&parmse->pre, ctree,
2679 fold_convert (TREE_TYPE (ctree), tmp));
2681 /* Now set the data field. */
2682 cmp = gfc_find_component (declared, "_data", true, true);
2683 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2684 TREE_TYPE (cmp->backend_decl),
2685 var, cmp->backend_decl, NULL_TREE);
2686 ss = gfc_walk_expr (e);
2687 if (ss == gfc_ss_terminator)
2690 gfc_conv_expr_reference (parmse, e);
2691 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2692 gfc_add_modify (&parmse->pre, ctree, tmp);
2697 gfc_conv_expr (parmse, e);
2698 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2701 /* Pass the address of the class object. */
2702 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2706 /* The following routine generates code for the intrinsic
2707 procedures from the ISO_C_BINDING module:
2709 * C_FUNLOC (function)
2710 * C_F_POINTER (subroutine)
2711 * C_F_PROCPOINTER (subroutine)
2712 * C_ASSOCIATED (function)
2713 One exception which is not handled here is C_F_POINTER with non-scalar
2714 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2717 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2718 gfc_actual_arglist * arg)
2723 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2725 if (arg->expr->rank == 0)
2726 gfc_conv_expr_reference (se, arg->expr);
2730 /* This is really the actual arg because no formal arglist is
2731 created for C_LOC. */
2732 fsym = arg->expr->symtree->n.sym;
2734 /* We should want it to do g77 calling convention. */
2736 && !(fsym->attr.pointer || fsym->attr.allocatable)
2737 && fsym->as->type != AS_ASSUMED_SHAPE;
2738 f = f || !sym->attr.always_explicit;
2740 argss = gfc_walk_expr (arg->expr);
2741 gfc_conv_array_parameter (se, arg->expr, argss, f,
2745 /* TODO -- the following two lines shouldn't be necessary, but if
2746 they're removed, a bug is exposed later in the code path.
2747 This workaround was thus introduced, but will have to be
2748 removed; please see PR 35150 for details about the issue. */
2749 se->expr = convert (pvoid_type_node, se->expr);
2750 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2754 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2756 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2757 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2758 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2759 gfc_conv_expr_reference (se, arg->expr);
2763 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2764 && arg->next->expr->rank == 0)
2765 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2767 /* Convert c_f_pointer if fptr is a scalar
2768 and convert c_f_procpointer. */
2772 gfc_init_se (&cptrse, NULL);
2773 gfc_conv_expr (&cptrse, arg->expr);
2774 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2775 gfc_add_block_to_block (&se->post, &cptrse.post);
2777 gfc_init_se (&fptrse, NULL);
2778 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2779 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2780 fptrse.want_pointer = 1;
2782 gfc_conv_expr (&fptrse, arg->next->expr);
2783 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2784 gfc_add_block_to_block (&se->post, &fptrse.post);
2786 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2787 && arg->next->expr->symtree->n.sym->attr.dummy)
2788 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2791 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2792 TREE_TYPE (fptrse.expr),
2794 fold_convert (TREE_TYPE (fptrse.expr),
2799 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2804 /* Build the addr_expr for the first argument. The argument is
2805 already an *address* so we don't need to set want_pointer in
2807 gfc_init_se (&arg1se, NULL);
2808 gfc_conv_expr (&arg1se, arg->expr);
2809 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2810 gfc_add_block_to_block (&se->post, &arg1se.post);
2812 /* See if we were given two arguments. */
2813 if (arg->next == NULL)
2814 /* Only given one arg so generate a null and do a
2815 not-equal comparison against the first arg. */
2816 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2818 fold_convert (TREE_TYPE (arg1se.expr),
2819 null_pointer_node));
2825 /* Given two arguments so build the arg2se from second arg. */
2826 gfc_init_se (&arg2se, NULL);
2827 gfc_conv_expr (&arg2se, arg->next->expr);
2828 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2829 gfc_add_block_to_block (&se->post, &arg2se.post);
2831 /* Generate test to compare that the two args are equal. */
2832 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2833 arg1se.expr, arg2se.expr);
2834 /* Generate test to ensure that the first arg is not null. */
2835 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2837 arg1se.expr, null_pointer_node);
2839 /* Finally, the generated test must check that both arg1 is not
2840 NULL and that it is equal to the second arg. */
2841 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2843 not_null_expr, eq_expr);
2849 /* Nothing was done. */
2854 /* Generate code for a procedure call. Note can return se->post != NULL.
2855 If se->direct_byref is set then se->expr contains the return parameter.
2856 Return nonzero, if the call has alternate specifiers.
2857 'expr' is only needed for procedure pointer components. */
2860 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2861 gfc_actual_arglist * args, gfc_expr * expr,
2862 VEC(tree,gc) *append_args)
2864 gfc_interface_mapping mapping;
2865 VEC(tree,gc) *arglist;
2866 VEC(tree,gc) *retargs;
2871 gfc_array_info *info;
2877 VEC(tree,gc) *stringargs;
2879 gfc_formal_arglist *formal;
2880 gfc_actual_arglist *arg;
2881 int has_alternate_specifier = 0;
2882 bool need_interface_mapping;
2889 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2890 gfc_component *comp = NULL;
2900 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2901 && conv_isocbinding_procedure (se, sym, args))
2904 gfc_is_proc_ptr_comp (expr, &comp);
2908 if (!sym->attr.elemental)
2910 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
2911 if (se->ss->info->useflags)
2913 gcc_assert ((!comp && gfc_return_by_reference (sym)
2914 && sym->result->attr.dimension)
2915 || (comp && comp->attr.dimension));
2916 gcc_assert (se->loop != NULL);
2918 /* Access the previously obtained result. */
2919 gfc_conv_tmp_array_ref (se);
2923 info = &se->ss->info->data.array;
2928 gfc_init_block (&post);
2929 gfc_init_interface_mapping (&mapping);
2932 formal = sym->formal;
2933 need_interface_mapping = sym->attr.dimension ||
2934 (sym->ts.type == BT_CHARACTER
2935 && sym->ts.u.cl->length
2936 && sym->ts.u.cl->length->expr_type
2941 formal = comp->formal;
2942 need_interface_mapping = comp->attr.dimension ||
2943 (comp->ts.type == BT_CHARACTER
2944 && comp->ts.u.cl->length
2945 && comp->ts.u.cl->length->expr_type
2949 /* Evaluate the arguments. */
2950 for (arg = args; arg != NULL;
2951 arg = arg->next, formal = formal ? formal->next : NULL)
2954 fsym = formal ? formal->sym : NULL;
2955 parm_kind = MISSING;
2959 if (se->ignore_optional)
2961 /* Some intrinsics have already been resolved to the correct
2965 else if (arg->label)
2967 has_alternate_specifier = 1;
2972 /* Pass a NULL pointer for an absent arg. */
2973 gfc_init_se (&parmse, NULL);
2974 parmse.expr = null_pointer_node;
2975 if (arg->missing_arg_type == BT_CHARACTER)
2976 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2979 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2981 /* Pass a NULL pointer to denote an absent arg. */
2982 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2983 gfc_init_se (&parmse, NULL);
2984 parmse.expr = null_pointer_node;
2985 if (arg->missing_arg_type == BT_CHARACTER)
2986 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2988 else if (fsym && fsym->ts.type == BT_CLASS
2989 && e->ts.type == BT_DERIVED)
2991 /* The derived type needs to be converted to a temporary
2993 gfc_init_se (&parmse, se);
2994 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2996 else if (se->ss && se->ss->info->useflags)
2998 /* An elemental function inside a scalarized loop. */
2999 gfc_init_se (&parmse, se);
3000 gfc_conv_expr_reference (&parmse, e);
3001 parm_kind = ELEMENTAL;
3005 /* A scalar or transformational function. */
3006 gfc_init_se (&parmse, NULL);
3007 argss = gfc_walk_expr (e);
3009 if (argss == gfc_ss_terminator)
3011 if (e->expr_type == EXPR_VARIABLE
3012 && e->symtree->n.sym->attr.cray_pointee
3013 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3015 /* The Cray pointer needs to be converted to a pointer to
3016 a type given by the expression. */
3017 gfc_conv_expr (&parmse, e);
3018 type = build_pointer_type (TREE_TYPE (parmse.expr));
3019 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3020 parmse.expr = convert (type, tmp);
3022 else if (fsym && fsym->attr.value)
3024 if (fsym->ts.type == BT_CHARACTER
3025 && fsym->ts.is_c_interop
3026 && fsym->ns->proc_name != NULL
3027 && fsym->ns->proc_name->attr.is_bind_c)
3030 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3031 if (parmse.expr == NULL)
3032 gfc_conv_expr (&parmse, e);
3035 gfc_conv_expr (&parmse, e);
3037 else if (arg->name && arg->name[0] == '%')
3038 /* Argument list functions %VAL, %LOC and %REF are signalled
3039 through arg->name. */
3040 conv_arglist_function (&parmse, arg->expr, arg->name);
3041 else if ((e->expr_type == EXPR_FUNCTION)
3042 && ((e->value.function.esym
3043 && e->value.function.esym->result->attr.pointer)
3044 || (!e->value.function.esym
3045 && e->symtree->n.sym->attr.pointer))
3046 && fsym && fsym->attr.target)
3048 gfc_conv_expr (&parmse, e);
3049 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3051 else if (e->expr_type == EXPR_FUNCTION
3052 && e->symtree->n.sym->result
3053 && e->symtree->n.sym->result != e->symtree->n.sym
3054 && e->symtree->n.sym->result->attr.proc_pointer)
3056 /* Functions returning procedure pointers. */
3057 gfc_conv_expr (&parmse, e);
3058 if (fsym && fsym->attr.proc_pointer)
3059 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3063 gfc_conv_expr_reference (&parmse, e);
3065 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3066 allocated on entry, it must be deallocated. */
3067 if (fsym && fsym->attr.allocatable
3068 && fsym->attr.intent == INTENT_OUT)
3072 gfc_init_block (&block);
3073 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3075 gfc_add_expr_to_block (&block, tmp);
3076 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3077 void_type_node, parmse.expr,
3079 gfc_add_expr_to_block (&block, tmp);
3081 if (fsym->attr.optional
3082 && e->expr_type == EXPR_VARIABLE
3083 && e->symtree->n.sym->attr.optional)
3085 tmp = fold_build3_loc (input_location, COND_EXPR,
3087 gfc_conv_expr_present (e->symtree->n.sym),
3088 gfc_finish_block (&block),
3089 build_empty_stmt (input_location));
3092 tmp = gfc_finish_block (&block);
3094 gfc_add_expr_to_block (&se->pre, tmp);
3097 if (fsym && e->expr_type != EXPR_NULL
3098 && ((fsym->attr.pointer
3099 && fsym->attr.flavor != FL_PROCEDURE)
3100 || (fsym->attr.proc_pointer
3101 && !(e->expr_type == EXPR_VARIABLE
3102 && e->symtree->n.sym->attr.dummy))
3103 || (fsym->attr.proc_pointer
3104 && e->expr_type == EXPR_VARIABLE
3105 && gfc_is_proc_ptr_comp (e, NULL))
3106 || fsym->attr.allocatable))
3108 /* Scalar pointer dummy args require an extra level of
3109 indirection. The null pointer already contains
3110 this level of indirection. */
3111 parm_kind = SCALAR_POINTER;
3112 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3118 /* If the procedure requires an explicit interface, the actual
3119 argument is passed according to the corresponding formal
3120 argument. If the corresponding formal argument is a POINTER,
3121 ALLOCATABLE or assumed shape, we do not use g77's calling
3122 convention, and pass the address of the array descriptor
3123 instead. Otherwise we use g77's calling convention. */
3126 && !(fsym->attr.pointer || fsym->attr.allocatable)
3127 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3129 f = f || !comp->attr.always_explicit;
3131 f = f || !sym->attr.always_explicit;
3133 /* If the argument is a function call that may not create
3134 a temporary for the result, we have to check that we
3135 can do it, i.e. that there is no alias between this
3136 argument and another one. */
3137 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3143 intent = fsym->attr.intent;
3145 intent = INTENT_UNKNOWN;
3147 if (gfc_check_fncall_dependency (e, intent, sym, args,
3149 parmse.force_tmp = 1;
3151 iarg = e->value.function.actual->expr;
3153 /* Temporary needed if aliasing due to host association. */
3154 if (sym->attr.contained
3156 && !sym->attr.implicit_pure
3157 && !sym->attr.use_assoc
3158 && iarg->expr_type == EXPR_VARIABLE
3159 && sym->ns == iarg->symtree->n.sym->ns)
3160 parmse.force_tmp = 1;
3162 /* Ditto within module. */
3163 if (sym->attr.use_assoc
3165 && !sym->attr.implicit_pure
3166 && iarg->expr_type == EXPR_VARIABLE
3167 && sym->module == iarg->symtree->n.sym->module)
3168 parmse.force_tmp = 1;
3171 if (e->expr_type == EXPR_VARIABLE
3172 && is_subref_array (e))
3173 /* The actual argument is a component reference to an
3174 array of derived types. In this case, the argument
3175 is converted to a temporary, which is passed and then
3176 written back after the procedure call. */
3177 gfc_conv_subref_array_arg (&parmse, e, f,
3178 fsym ? fsym->attr.intent : INTENT_INOUT,
3179 fsym && fsym->attr.pointer);
3181 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3184 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3185 allocated on entry, it must be deallocated. */
3186 if (fsym && fsym->attr.allocatable
3187 && fsym->attr.intent == INTENT_OUT)
3189 tmp = build_fold_indirect_ref_loc (input_location,
3191 tmp = gfc_trans_dealloc_allocated (tmp);
3192 if (fsym->attr.optional
3193 && e->expr_type == EXPR_VARIABLE
3194 && e->symtree->n.sym->attr.optional)
3195 tmp = fold_build3_loc (input_location, COND_EXPR,
3197 gfc_conv_expr_present (e->symtree->n.sym),
3198 tmp, build_empty_stmt (input_location));
3199 gfc_add_expr_to_block (&se->pre, tmp);
3204 /* The case with fsym->attr.optional is that of a user subroutine
3205 with an interface indicating an optional argument. When we call
3206 an intrinsic subroutine, however, fsym is NULL, but we might still
3207 have an optional argument, so we proceed to the substitution
3209 if (e && (fsym == NULL || fsym->attr.optional))
3211 /* If an optional argument is itself an optional dummy argument,
3212 check its presence and substitute a null if absent. This is
3213 only needed when passing an array to an elemental procedure
3214 as then array elements are accessed - or no NULL pointer is
3215 allowed and a "1" or "0" should be passed if not present.
3216 When passing a non-array-descriptor full array to a
3217 non-array-descriptor dummy, no check is needed. For
3218 array-descriptor actual to array-descriptor dummy, see
3219 PR 41911 for why a check has to be inserted.
3220 fsym == NULL is checked as intrinsics required the descriptor
3221 but do not always set fsym. */
3222 if (e->expr_type == EXPR_VARIABLE
3223 && e->symtree->n.sym->attr.optional
3224 && ((e->rank > 0 && sym->attr.elemental)
3225 || e->representation.length || e->ts.type == BT_CHARACTER
3229 && (fsym->as->type == AS_ASSUMED_SHAPE
3230 || fsym->as->type == AS_DEFERRED))))))
3231 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3232 e->representation.length);
3237 /* Obtain the character length of an assumed character length
3238 length procedure from the typespec. */
3239 if (fsym->ts.type == BT_CHARACTER
3240 && parmse.string_length == NULL_TREE
3241 && e->ts.type == BT_PROCEDURE
3242 && e->symtree->n.sym->ts.type == BT_CHARACTER
3243 && e->symtree->n.sym->ts.u.cl->length != NULL
3244 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3246 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3247 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3251 if (fsym && need_interface_mapping && e)
3252 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3254 gfc_add_block_to_block (&se->pre, &parmse.pre);
3255 gfc_add_block_to_block (&post, &parmse.post);
3257 /* Allocated allocatable components of derived types must be
3258 deallocated for non-variable scalars. Non-variable arrays are
3259 dealt with in trans-array.c(gfc_conv_array_parameter). */
3260 if (e && e->ts.type == BT_DERIVED
3261 && e->ts.u.derived->attr.alloc_comp
3262 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3263 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3266 tmp = build_fold_indirect_ref_loc (input_location,
3268 parm_rank = e->rank;
3276 case (SCALAR_POINTER):
3277 tmp = build_fold_indirect_ref_loc (input_location,
3282 if (e->expr_type == EXPR_OP
3283 && e->value.op.op == INTRINSIC_PARENTHESES
3284 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3287 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3288 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3289 gfc_add_expr_to_block (&se->post, local_tmp);
3292 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3294 gfc_add_expr_to_block (&se->post, tmp);
3297 /* Add argument checking of passing an unallocated/NULL actual to
3298 a nonallocatable/nonpointer dummy. */
3300 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3302 symbol_attribute attr;
3306 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3307 attr = gfc_expr_attr (e);
3309 goto end_pointer_check;
3311 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3312 allocatable to an optional dummy, cf. 12.5.2.12. */
3313 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3314 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3315 goto end_pointer_check;
3319 /* If the actual argument is an optional pointer/allocatable and
3320 the formal argument takes an nonpointer optional value,
3321 it is invalid to pass a non-present argument on, even
3322 though there is no technical reason for this in gfortran.
3323 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3324 tree present, null_ptr, type;
3326 if (attr.allocatable
3327 && (fsym == NULL || !fsym->attr.allocatable))
3328 asprintf (&msg, "Allocatable actual argument '%s' is not "
3329 "allocated or not present", e->symtree->n.sym->name);
3330 else if (attr.pointer
3331 && (fsym == NULL || !fsym->attr.pointer))
3332 asprintf (&msg, "Pointer actual argument '%s' is not "
3333 "associated or not present",
3334 e->symtree->n.sym->name);
3335 else if (attr.proc_pointer
3336 && (fsym == NULL || !fsym->attr.proc_pointer))
3337 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3338 "associated or not present",
3339 e->symtree->n.sym->name);
3341 goto end_pointer_check;
3343 present = gfc_conv_expr_present (e->symtree->n.sym);
3344 type = TREE_TYPE (present);
3345 present = fold_build2_loc (input_location, EQ_EXPR,
3346 boolean_type_node, present,
3348 null_pointer_node));
3349 type = TREE_TYPE (parmse.expr);
3350 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3351 boolean_type_node, parmse.expr,
3353 null_pointer_node));
3354 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3355 boolean_type_node, present, null_ptr);
3359 if (attr.allocatable
3360 && (fsym == NULL || !fsym->attr.allocatable))
3361 asprintf (&msg, "Allocatable actual argument '%s' is not "
3362 "allocated", e->symtree->n.sym->name);
3363 else if (attr.pointer
3364 && (fsym == NULL || !fsym->attr.pointer))
3365 asprintf (&msg, "Pointer actual argument '%s' is not "
3366 "associated", e->symtree->n.sym->name);
3367 else if (attr.proc_pointer
3368 && (fsym == NULL || !fsym->attr.proc_pointer))
3369 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3370 "associated", e->symtree->n.sym->name);
3372 goto end_pointer_check;
3376 /* If the argument is passed by value, we need to strip the
3378 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3379 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3381 cond = fold_build2_loc (input_location, EQ_EXPR,
3382 boolean_type_node, tmp,
3383 fold_convert (TREE_TYPE (tmp),
3384 null_pointer_node));
3387 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3393 /* Deferred length dummies pass the character length by reference
3394 so that the value can be returned. */
3395 if (parmse.string_length && fsym && fsym->ts.deferred)
3397 tmp = parmse.string_length;
3398 if (TREE_CODE (tmp) != VAR_DECL)
3399 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3400 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3403 /* Character strings are passed as two parameters, a length and a
3404 pointer - except for Bind(c) which only passes the pointer. */
3405 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3406 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3408 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3409 pass the token and the offset as additional arguments. */
3410 if (fsym && fsym->attr.codimension
3411 && gfc_option.coarray == GFC_FCOARRAY_LIB
3412 && !fsym->attr.allocatable
3415 /* Token and offset. */
3416 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
3417 VEC_safe_push (tree, gc, stringargs,
3418 build_int_cst (gfc_array_index_type, 0));
3419 gcc_assert (fsym->attr.optional);
3421 else if (fsym && fsym->attr.codimension
3422 && !fsym->attr.allocatable
3423 && gfc_option.coarray == GFC_FCOARRAY_LIB)
3425 tree caf_decl, caf_type;
3428 caf_decl = get_tree_for_caf_expr (e);
3429 caf_type = TREE_TYPE (caf_decl);
3431 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3432 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3433 tmp = gfc_conv_descriptor_token (caf_decl);
3434 else if (DECL_LANG_SPECIFIC (caf_decl)
3435 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
3436 tmp = GFC_DECL_TOKEN (caf_decl);
3439 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
3440 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
3441 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
3444 VEC_safe_push (tree, gc, stringargs, tmp);
3446 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3447 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3448 offset = build_int_cst (gfc_array_index_type, 0);
3449 else if (DECL_LANG_SPECIFIC (caf_decl)
3450 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
3451 offset = GFC_DECL_CAF_OFFSET (caf_decl);
3452 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3453 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
3455 offset = build_int_cst (gfc_array_index_type, 0);
3457 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
3458 tmp = gfc_conv_descriptor_data_get (caf_decl);
3461 gcc_assert (POINTER_TYPE_P (caf_type));
3465 if (fsym->as->type == AS_ASSUMED_SHAPE)
3467 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3468 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3469 (TREE_TYPE (parmse.expr))));
3470 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
3471 tmp2 = gfc_conv_descriptor_data_get (tmp2);
3473 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3474 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
3477 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3481 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3482 gfc_array_index_type,
3483 fold_convert (gfc_array_index_type, tmp2),
3484 fold_convert (gfc_array_index_type, tmp));
3485 offset = fold_build2_loc (input_location, PLUS_EXPR,
3486 gfc_array_index_type, offset, tmp);
3488 VEC_safe_push (tree, gc, stringargs, offset);
3491 VEC_safe_push (tree, gc, arglist, parmse.expr);
3493 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3500 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3501 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3502 else if (ts.type == BT_CHARACTER)
3504 if (ts.u.cl->length == NULL)
3506 /* Assumed character length results are not allowed by 5.1.1.5 of the
3507 standard and are trapped in resolve.c; except in the case of SPREAD
3508 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3509 we take the character length of the first argument for the result.
3510 For dummies, we have to look through the formal argument list for
3511 this function and use the character length found there.*/
3512 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3513 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3514 else if (!sym->attr.dummy)
3515 cl.backend_decl = VEC_index (tree, stringargs, 0);
3518 formal = sym->ns->proc_name->formal;
3519 for (; formal; formal = formal->next)
3520 if (strcmp (formal->sym->name, sym->name) == 0)
3521 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3528 /* Calculate the length of the returned string. */
3529 gfc_init_se (&parmse, NULL);
3530 if (need_interface_mapping)
3531 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3533 gfc_conv_expr (&parmse, ts.u.cl->length);
3534 gfc_add_block_to_block (&se->pre, &parmse.pre);
3535 gfc_add_block_to_block (&se->post, &parmse.post);
3537 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3538 tmp = fold_build2_loc (input_location, MAX_EXPR,
3539 gfc_charlen_type_node, tmp,
3540 build_int_cst (gfc_charlen_type_node, 0));
3541 cl.backend_decl = tmp;
3544 /* Set up a charlen structure for it. */
3549 len = cl.backend_decl;
3552 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3553 || (!comp && gfc_return_by_reference (sym));
3556 if (se->direct_byref)
3558 /* Sometimes, too much indirection can be applied; e.g. for
3559 function_result = array_valued_recursive_function. */
3560 if (TREE_TYPE (TREE_TYPE (se->expr))
3561 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3562 && GFC_DESCRIPTOR_TYPE_P
3563 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3564 se->expr = build_fold_indirect_ref_loc (input_location,
3567 /* If the lhs of an assignment x = f(..) is allocatable and
3568 f2003 is allowed, we must do the automatic reallocation.
3569 TODO - deal with intrinsics, without using a temporary. */
3570 if (gfc_option.flag_realloc_lhs
3571 && se->ss && se->ss->loop_chain
3572 && se->ss->loop_chain->is_alloc_lhs
3573 && !expr->value.function.isym
3574 && sym->result->as != NULL)
3576 /* Evaluate the bounds of the result, if known. */
3577 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3580 /* Perform the automatic reallocation. */
3581 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3583 gfc_add_expr_to_block (&se->pre, tmp);
3585 /* Pass the temporary as the first argument. */
3586 result = info->descriptor;
3589 result = build_fold_indirect_ref_loc (input_location,
3591 VEC_safe_push (tree, gc, retargs, se->expr);
3593 else if (comp && comp->attr.dimension)
3595 gcc_assert (se->loop && info);
3597 /* Set the type of the array. */
3598 tmp = gfc_typenode_for_spec (&comp->ts);
3599 gcc_assert (se->ss->dimen == se->loop->dimen);
3601 /* Evaluate the bounds of the result, if known. */
3602 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3604 /* If the lhs of an assignment x = f(..) is allocatable and
3605 f2003 is allowed, we must not generate the function call
3606 here but should just send back the results of the mapping.
3607 This is signalled by the function ss being flagged. */
3608 if (gfc_option.flag_realloc_lhs
3609 && se->ss && se->ss->is_alloc_lhs)
3611 gfc_free_interface_mapping (&mapping);
3612 return has_alternate_specifier;
3615 /* Create a temporary to store the result. In case the function
3616 returns a pointer, the temporary will be a shallow copy and
3617 mustn't be deallocated. */
3618 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3619 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
3620 tmp, NULL_TREE, false,
3621 !comp->attr.pointer, callee_alloc,
3622 &se->ss->info->expr->where);
3624 /* Pass the temporary as the first argument. */
3625 result = info->descriptor;
3626 tmp = gfc_build_addr_expr (NULL_TREE, result);
3627 VEC_safe_push (tree, gc, retargs, tmp);
3629 else if (!comp && sym->result->attr.dimension)
3631 gcc_assert (se->loop && info);
3633 /* Set the type of the array. */
3634 tmp = gfc_typenode_for_spec (&ts);
3635 gcc_assert (se->ss->dimen == se->loop->dimen);
3637 /* Evaluate the bounds of the result, if known. */
3638 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3640 /* If the lhs of an assignment x = f(..) is allocatable and
3641 f2003 is allowed, we must not generate the function call
3642 here but should just send back the results of the mapping.
3643 This is signalled by the function ss being flagged. */
3644 if (gfc_option.flag_realloc_lhs
3645 && se->ss && se->ss->is_alloc_lhs)
3647 gfc_free_interface_mapping (&mapping);
3648 return has_alternate_specifier;
3651 /* Create a temporary to store the result. In case the function
3652 returns a pointer, the temporary will be a shallow copy and
3653 mustn't be deallocated. */
3654 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3655 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
3656 tmp, NULL_TREE, false,
3657 !sym->attr.pointer, callee_alloc,
3658 &se->ss->info->expr->where);
3660 /* Pass the temporary as the first argument. */
3661 result = info->descriptor;
3662 tmp = gfc_build_addr_expr (NULL_TREE, result);
3663 VEC_safe_push (tree, gc, retargs, tmp);
3665 else if (ts.type == BT_CHARACTER)
3667 /* Pass the string length. */
3668 type = gfc_get_character_type (ts.kind, ts.u.cl);
3669 type = build_pointer_type (type);
3671 /* Return an address to a char[0:len-1]* temporary for
3672 character pointers. */
3673 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3674 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3676 var = gfc_create_var (type, "pstr");
3678 if ((!comp && sym->attr.allocatable)
3679 || (comp && comp->attr.allocatable))
3680 gfc_add_modify (&se->pre, var,
3681 fold_convert (TREE_TYPE (var),
3682 null_pointer_node));
3684 /* Provide an address expression for the function arguments. */
3685 var = gfc_build_addr_expr (NULL_TREE, var);
3688 var = gfc_conv_string_tmp (se, type, len);
3690 VEC_safe_push (tree, gc, retargs, var);
3694 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3696 type = gfc_get_complex_type (ts.kind);
3697 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3698 VEC_safe_push (tree, gc, retargs, var);
3701 if (ts.type == BT_CHARACTER && ts.deferred
3702 && (sym->attr.allocatable || sym->attr.pointer))
3705 if (TREE_CODE (tmp) != VAR_DECL)
3706 tmp = gfc_evaluate_now (len, &se->pre);
3707 len = gfc_build_addr_expr (NULL_TREE, tmp);
3710 /* Add the string length to the argument list. */
3711 if (ts.type == BT_CHARACTER)
3712 VEC_safe_push (tree, gc, retargs, len);
3714 gfc_free_interface_mapping (&mapping);
3716 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3717 arglen = (VEC_length (tree, arglist)
3718 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3719 VEC_reserve_exact (tree, gc, retargs, arglen);
3721 /* Add the return arguments. */
3722 VEC_splice (tree, retargs, arglist);
3724 /* Add the hidden string length parameters to the arguments. */
3725 VEC_splice (tree, retargs, stringargs);
3727 /* We may want to append extra arguments here. This is used e.g. for
3728 calls to libgfortran_matmul_??, which need extra information. */
3729 if (!VEC_empty (tree, append_args))
3730 VEC_splice (tree, retargs, append_args);
3733 /* Generate the actual call. */
3734 conv_function_val (se, sym, expr);
3736 /* If there are alternate return labels, function type should be
3737 integer. Can't modify the type in place though, since it can be shared
3738 with other functions. For dummy arguments, the typing is done to
3739 this result, even if it has to be repeated for each call. */
3740 if (has_alternate_specifier
3741 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3743 if (!sym->attr.dummy)
3745 TREE_TYPE (sym->backend_decl)
3746 = build_function_type (integer_type_node,
3747 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3748 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3751 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3754 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3755 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3757 /* If we have a pointer function, but we don't want a pointer, e.g.
3760 where f is pointer valued, we have to dereference the result. */
3761 if (!se->want_pointer && !byref
3762 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3763 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3764 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3766 /* f2c calling conventions require a scalar default real function to
3767 return a double precision result. Convert this back to default
3768 real. We only care about the cases that can happen in Fortran 77.
3770 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3771 && sym->ts.kind == gfc_default_real_kind
3772 && !sym->attr.always_explicit)
3773 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3775 /* A pure function may still have side-effects - it may modify its
3777 TREE_SIDE_EFFECTS (se->expr) = 1;
3779 if (!sym->attr.pure)
3780 TREE_SIDE_EFFECTS (se->expr) = 1;
3785 /* Add the function call to the pre chain. There is no expression. */
3786 gfc_add_expr_to_block (&se->pre, se->expr);
3787 se->expr = NULL_TREE;
3789 if (!se->direct_byref)
3791 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3793 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3795 /* Check the data pointer hasn't been modified. This would
3796 happen in a function returning a pointer. */
3797 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3798 tmp = fold_build2_loc (input_location, NE_EXPR,
3801 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3804 se->expr = info->descriptor;
3805 /* Bundle in the string length. */
3806 se->string_length = len;
3808 else if (ts.type == BT_CHARACTER)
3810 /* Dereference for character pointer results. */
3811 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3812 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3813 se->expr = build_fold_indirect_ref_loc (input_location, var);
3818 se->string_length = len;
3819 else if (sym->attr.allocatable || sym->attr.pointer)
3820 se->string_length = cl.backend_decl;
3824 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3825 se->expr = build_fold_indirect_ref_loc (input_location, var);
3830 /* Follow the function call with the argument post block. */
3833 gfc_add_block_to_block (&se->pre, &post);
3835 /* Transformational functions of derived types with allocatable
3836 components must have the result allocatable components copied. */
3837 arg = expr->value.function.actual;
3838 if (result && arg && expr->rank
3839 && expr->value.function.isym
3840 && expr->value.function.isym->transformational
3841 && arg->expr->ts.type == BT_DERIVED
3842 && arg->expr->ts.u.derived->attr.alloc_comp)
3845 /* Copy the allocatable components. We have to use a
3846 temporary here to prevent source allocatable components
3847 from being corrupted. */
3848 tmp2 = gfc_evaluate_now (result, &se->pre);
3849 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3850 result, tmp2, expr->rank);
3851 gfc_add_expr_to_block (&se->pre, tmp);
3852 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3854 gfc_add_expr_to_block (&se->pre, tmp);
3856 /* Finally free the temporary's data field. */
3857 tmp = gfc_conv_descriptor_data_get (tmp2);
3858 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3859 gfc_add_expr_to_block (&se->pre, tmp);
3863 gfc_add_block_to_block (&se->post, &post);
3865 return has_alternate_specifier;
3869 /* Fill a character string with spaces. */
3872 fill_with_spaces (tree start, tree type, tree size)
3874 stmtblock_t block, loop;
3875 tree i, el, exit_label, cond, tmp;
3877 /* For a simple char type, we can call memset(). */
3878 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3879 return build_call_expr_loc (input_location,
3880 builtin_decl_explicit (BUILT_IN_MEMSET),
3882 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3883 lang_hooks.to_target_charset (' ')),
3886 /* Otherwise, we use a loop:
3887 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3891 /* Initialize variables. */
3892 gfc_init_block (&block);
3893 i = gfc_create_var (sizetype, "i");
3894 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3895 el = gfc_create_var (build_pointer_type (type), "el");
3896 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3897 exit_label = gfc_build_label_decl (NULL_TREE);
3898 TREE_USED (exit_label) = 1;
3902 gfc_init_block (&loop);
3904 /* Exit condition. */
3905 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3906 build_zero_cst (sizetype));
3907 tmp = build1_v (GOTO_EXPR, exit_label);
3908 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3909 build_empty_stmt (input_location));
3910 gfc_add_expr_to_block (&loop, tmp);
3913 gfc_add_modify (&loop,
3914 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3915 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3917 /* Increment loop variables. */
3918 gfc_add_modify (&loop, i,
3919 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3920 TYPE_SIZE_UNIT (type)));
3921 gfc_add_modify (&loop, el,
3922 fold_build_pointer_plus_loc (input_location,
3923 el, TYPE_SIZE_UNIT (type)));
3925 /* Making the loop... actually loop! */
3926 tmp = gfc_finish_block (&loop);
3927 tmp = build1_v (LOOP_EXPR, tmp);
3928 gfc_add_expr_to_block (&block, tmp);
3930 /* The exit label. */
3931 tmp = build1_v (LABEL_EXPR, exit_label);
3932 gfc_add_expr_to_block (&block, tmp);
3935 return gfc_finish_block (&block);
3939 /* Generate code to copy a string. */
3942 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3943 int dkind, tree slength, tree src, int skind)
3945 tree tmp, dlen, slen;
3954 stmtblock_t tempblock;
3956 gcc_assert (dkind == skind);
3958 if (slength != NULL_TREE)
3960 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3961 ssc = gfc_string_to_single_character (slen, src, skind);
3965 slen = build_int_cst (size_type_node, 1);
3969 if (dlength != NULL_TREE)
3971 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3972 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3976 dlen = build_int_cst (size_type_node, 1);
3980 /* Assign directly if the types are compatible. */
3981 if (dsc != NULL_TREE && ssc != NULL_TREE
3982 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3984 gfc_add_modify (block, dsc, ssc);
3988 /* Do nothing if the destination length is zero. */
3989 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3990 build_int_cst (size_type_node, 0));
3992 /* The following code was previously in _gfortran_copy_string:
3994 // The two strings may overlap so we use memmove.
3996 copy_string (GFC_INTEGER_4 destlen, char * dest,
3997 GFC_INTEGER_4 srclen, const char * src)
3999 if (srclen >= destlen)
4001 // This will truncate if too long.
4002 memmove (dest, src, destlen);
4006 memmove (dest, src, srclen);
4008 memset (&dest[srclen], ' ', destlen - srclen);
4012 We're now doing it here for better optimization, but the logic
4015 /* For non-default character kinds, we have to multiply the string
4016 length by the base type size. */
4017 chartype = gfc_get_char_type (dkind);
4018 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4019 fold_convert (size_type_node, slen),
4020 fold_convert (size_type_node,
4021 TYPE_SIZE_UNIT (chartype)));
4022 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4023 fold_convert (size_type_node, dlen),
4024 fold_convert (size_type_node,
4025 TYPE_SIZE_UNIT (chartype)));
4027 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4028 dest = fold_convert (pvoid_type_node, dest);
4030 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4032 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4033 src = fold_convert (pvoid_type_node, src);
4035 src = gfc_build_addr_expr (pvoid_type_node, src);
4037 /* Truncate string if source is too long. */
4038 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4040 tmp2 = build_call_expr_loc (input_location,
4041 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4042 3, dest, src, dlen);
4044 /* Else copy and pad with spaces. */
4045 tmp3 = build_call_expr_loc (input_location,
4046 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4047 3, dest, src, slen);
4049 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4050 tmp4 = fill_with_spaces (tmp4, chartype,
4051 fold_build2_loc (input_location, MINUS_EXPR,
4052 TREE_TYPE(dlen), dlen, slen));
4054 gfc_init_block (&tempblock);
4055 gfc_add_expr_to_block (&tempblock, tmp3);
4056 gfc_add_expr_to_block (&tempblock, tmp4);
4057 tmp3 = gfc_finish_block (&tempblock);
4059 /* The whole copy_string function is there. */
4060 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4062 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4063 build_empty_stmt (input_location));
4064 gfc_add_expr_to_block (block, tmp);
4068 /* Translate a statement function.
4069 The value of a statement function reference is obtained by evaluating the
4070 expression using the values of the actual arguments for the values of the
4071 corresponding dummy arguments. */
4074 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4078 gfc_formal_arglist *fargs;
4079 gfc_actual_arglist *args;
4082 gfc_saved_var *saved_vars;
4088 sym = expr->symtree->n.sym;
4089 args = expr->value.function.actual;
4090 gfc_init_se (&lse, NULL);
4091 gfc_init_se (&rse, NULL);
4094 for (fargs = sym->formal; fargs; fargs = fargs->next)
4096 saved_vars = XCNEWVEC (gfc_saved_var, n);
4097 temp_vars = XCNEWVEC (tree, n);
4099 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4101 /* Each dummy shall be specified, explicitly or implicitly, to be
4103 gcc_assert (fargs->sym->attr.dimension == 0);
4106 if (fsym->ts.type == BT_CHARACTER)
4108 /* Copy string arguments. */
4111 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4112 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4114 /* Create a temporary to hold the value. */
4115 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4116 fsym->ts.u.cl->backend_decl
4117 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4119 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4120 temp_vars[n] = gfc_create_var (type, fsym->name);
4122 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4124 gfc_conv_expr (&rse, args->expr);
4125 gfc_conv_string_parameter (&rse);
4126 gfc_add_block_to_block (&se->pre, &lse.pre);
4127 gfc_add_block_to_block (&se->pre, &rse.pre);
4129 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4130 rse.string_length, rse.expr, fsym->ts.kind);
4131 gfc_add_block_to_block (&se->pre, &lse.post);
4132 gfc_add_block_to_block (&se->pre, &rse.post);
4136 /* For everything else, just evaluate the expression. */
4138 /* Create a temporary to hold the value. */
4139 type = gfc_typenode_for_spec (&fsym->ts);
4140 temp_vars[n] = gfc_create_var (type, fsym->name);
4142 gfc_conv_expr (&lse, args->expr);
4144 gfc_add_block_to_block (&se->pre, &lse.pre);
4145 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4146 gfc_add_block_to_block (&se->pre, &lse.post);
4152 /* Use the temporary variables in place of the real ones. */
4153 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4154 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4156 gfc_conv_expr (se, sym->value);
4158 if (sym->ts.type == BT_CHARACTER)
4160 gfc_conv_const_charlen (sym->ts.u.cl);
4162 /* Force the expression to the correct length. */
4163 if (!INTEGER_CST_P (se->string_length)
4164 || tree_int_cst_lt (se->string_length,
4165 sym->ts.u.cl->backend_decl))
4167 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4168 tmp = gfc_create_var (type, sym->name);
4169 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4170 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4171 sym->ts.kind, se->string_length, se->expr,
4175 se->string_length = sym->ts.u.cl->backend_decl;
4178 /* Restore the original variables. */
4179 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4180 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4185 /* Translate a function expression. */
4188 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4192 if (expr->value.function.isym)
4194 gfc_conv_intrinsic_function (se, expr);
4198 /* We distinguish statement functions from general functions to improve
4199 runtime performance. */
4200 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4202 gfc_conv_statement_function (se, expr);
4206 /* expr.value.function.esym is the resolved (specific) function symbol for
4207 most functions. However this isn't set for dummy procedures. */
4208 sym = expr->value.function.esym;
4210 sym = expr->symtree->n.sym;
4212 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4216 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4219 is_zero_initializer_p (gfc_expr * expr)
4221 if (expr->expr_type != EXPR_CONSTANT)
4224 /* We ignore constants with prescribed memory representations for now. */
4225 if (expr->representation.string)
4228 switch (expr->ts.type)
4231 return mpz_cmp_si (expr->value.integer, 0) == 0;
4234 return mpfr_zero_p (expr->value.real)
4235 && MPFR_SIGN (expr->value.real) >= 0;
4238 return expr->value.logical == 0;
4241 return mpfr_zero_p (mpc_realref (expr->value.complex))
4242 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4243 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4244 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4254 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4259 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
4260 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
4262 gfc_conv_tmp_array_ref (se);
4266 /* Build a static initializer. EXPR is the expression for the initial value.
4267 The other parameters describe the variable of the component being
4268 initialized. EXPR may be null. */
4271 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4272 bool array, bool pointer, bool procptr)
4276 if (!(expr || pointer || procptr))
4279 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4280 (these are the only two iso_c_binding derived types that can be
4281 used as initialization expressions). If so, we need to modify
4282 the 'expr' to be that for a (void *). */
4283 if (expr != NULL && expr->ts.type == BT_DERIVED
4284 && expr->ts.is_iso_c && expr->ts.u.derived)
4286 gfc_symbol *derived = expr->ts.u.derived;
4288 /* The derived symbol has already been converted to a (void *). Use
4290 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4291 expr->ts.f90_type = derived->ts.f90_type;
4293 gfc_init_se (&se, NULL);
4294 gfc_conv_constant (&se, expr);
4295 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4299 if (array && !procptr)
4302 /* Arrays need special handling. */
4304 ctor = gfc_build_null_descriptor (type);
4305 /* Special case assigning an array to zero. */
4306 else if (is_zero_initializer_p (expr))
4307 ctor = build_constructor (type, NULL);
4309 ctor = gfc_conv_array_initializer (type, expr);
4310 TREE_STATIC (ctor) = 1;
4313 else if (pointer || procptr)
4315 if (!expr || expr->expr_type == EXPR_NULL)
4316 return fold_convert (type, null_pointer_node);
4319 gfc_init_se (&se, NULL);
4320 se.want_pointer = 1;
4321 gfc_conv_expr (&se, expr);
4322 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4332 gfc_init_se (&se, NULL);
4333 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4334 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4336 gfc_conv_structure (&se, expr, 1);
4337 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4338 TREE_STATIC (se.expr) = 1;
4343 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4344 TREE_STATIC (ctor) = 1;
4349 gfc_init_se (&se, NULL);
4350 gfc_conv_constant (&se, expr);
4351 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4358 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4364 gfc_array_info *lss_array;
4371 gfc_start_block (&block);
4373 /* Initialize the scalarizer. */
4374 gfc_init_loopinfo (&loop);
4376 gfc_init_se (&lse, NULL);
4377 gfc_init_se (&rse, NULL);
4380 rss = gfc_walk_expr (expr);
4381 if (rss == gfc_ss_terminator)
4382 /* The rhs is scalar. Add a ss for the expression. */
4383 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4385 /* Create a SS for the destination. */
4386 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4388 lss_array = &lss->info->data.array;
4389 lss_array->shape = gfc_get_shape (cm->as->rank);
4390 lss_array->descriptor = dest;
4391 lss_array->data = gfc_conv_array_data (dest);
4392 lss_array->offset = gfc_conv_array_offset (dest);
4393 for (n = 0; n < cm->as->rank; n++)
4395 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
4396 lss_array->stride[n] = gfc_index_one_node;
4398 mpz_init (lss_array->shape[n]);
4399 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
4400 cm->as->lower[n]->value.integer);
4401 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
4404 /* Associate the SS with the loop. */
4405 gfc_add_ss_to_loop (&loop, lss);
4406 gfc_add_ss_to_loop (&loop, rss);
4408 /* Calculate the bounds of the scalarization. */
4409 gfc_conv_ss_startstride (&loop);
4411 /* Setup the scalarizing loops. */
4412 gfc_conv_loop_setup (&loop, &expr->where);
4414 /* Setup the gfc_se structures. */
4415 gfc_copy_loopinfo_to_se (&lse, &loop);
4416 gfc_copy_loopinfo_to_se (&rse, &loop);
4419 gfc_mark_ss_chain_used (rss, 1);
4421 gfc_mark_ss_chain_used (lss, 1);
4423 /* Start the scalarized loop body. */
4424 gfc_start_scalarized_body (&loop, &body);
4426 gfc_conv_tmp_array_ref (&lse);
4427 if (cm->ts.type == BT_CHARACTER)
4428 lse.string_length = cm->ts.u.cl->backend_decl;
4430 gfc_conv_expr (&rse, expr);
4432 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4433 gfc_add_expr_to_block (&body, tmp);
4435 gcc_assert (rse.ss == gfc_ss_terminator);
4437 /* Generate the copying loops. */
4438 gfc_trans_scalarizing_loops (&loop, &body);
4440 /* Wrap the whole thing up. */
4441 gfc_add_block_to_block (&block, &loop.pre);
4442 gfc_add_block_to_block (&block, &loop.post);
4444 gcc_assert (lss_array->shape != NULL);
4445 gfc_free_shape (&lss_array->shape, cm->as->rank);
4446 gfc_cleanup_loop (&loop);
4448 return gfc_finish_block (&block);
4453 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4464 gfc_expr *arg = NULL;
4466 gfc_start_block (&block);
4467 gfc_init_se (&se, NULL);
4469 /* Get the descriptor for the expressions. */
4470 rss = gfc_walk_expr (expr);
4471 se.want_pointer = 0;
4472 gfc_conv_expr_descriptor (&se, expr, rss);
4473 gfc_add_block_to_block (&block, &se.pre);
4474 gfc_add_modify (&block, dest, se.expr);
4476 /* Deal with arrays of derived types with allocatable components. */
4477 if (cm->ts.type == BT_DERIVED
4478 && cm->ts.u.derived->attr.alloc_comp)
4479 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4483 tmp = gfc_duplicate_allocatable (dest, se.expr,
4484 TREE_TYPE(cm->backend_decl),
4487 gfc_add_expr_to_block (&block, tmp);
4488 gfc_add_block_to_block (&block, &se.post);
4490 if (expr->expr_type != EXPR_VARIABLE)
4491 gfc_conv_descriptor_data_set (&block, se.expr,
4494 /* We need to know if the argument of a conversion function is a
4495 variable, so that the correct lower bound can be used. */
4496 if (expr->expr_type == EXPR_FUNCTION
4497 && expr->value.function.isym
4498 && expr->value.function.isym->conversion
4499 && expr->value.function.actual->expr
4500 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4501 arg = expr->value.function.actual->expr;
4503 /* Obtain the array spec of full array references. */
4505 as = gfc_get_full_arrayspec_from_expr (arg);
4507 as = gfc_get_full_arrayspec_from_expr (expr);
4509 /* Shift the lbound and ubound of temporaries to being unity,
4510 rather than zero, based. Always calculate the offset. */
4511 offset = gfc_conv_descriptor_offset_get (dest);
4512 gfc_add_modify (&block, offset, gfc_index_zero_node);
4513 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4515 for (n = 0; n < expr->rank; n++)
4520 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4521 TODO It looks as if gfc_conv_expr_descriptor should return
4522 the correct bounds and that the following should not be
4523 necessary. This would simplify gfc_conv_intrinsic_bound
4525 if (as && as->lower[n])
4528 gfc_init_se (&lbse, NULL);
4529 gfc_conv_expr (&lbse, as->lower[n]);
4530 gfc_add_block_to_block (&block, &lbse.pre);
4531 lbound = gfc_evaluate_now (lbse.expr, &block);
4535 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4536 lbound = gfc_conv_descriptor_lbound_get (tmp,
4540 lbound = gfc_conv_descriptor_lbound_get (dest,
4543 lbound = gfc_index_one_node;
4545 lbound = fold_convert (gfc_array_index_type, lbound);
4547 /* Shift the bounds and set the offset accordingly. */
4548 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4549 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4550 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4551 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4553 gfc_conv_descriptor_ubound_set (&block, dest,
4554 gfc_rank_cst[n], tmp);
4555 gfc_conv_descriptor_lbound_set (&block, dest,
4556 gfc_rank_cst[n], lbound);
4558 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4559 gfc_conv_descriptor_lbound_get (dest,
4561 gfc_conv_descriptor_stride_get (dest,
4563 gfc_add_modify (&block, tmp2, tmp);
4564 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4566 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4571 /* If a conversion expression has a null data pointer
4572 argument, nullify the allocatable component. */
4576 if (arg->symtree->n.sym->attr.allocatable
4577 || arg->symtree->n.sym->attr.pointer)
4579 non_null_expr = gfc_finish_block (&block);
4580 gfc_start_block (&block);
4581 gfc_conv_descriptor_data_set (&block, dest,
4583 null_expr = gfc_finish_block (&block);
4584 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4585 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4586 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4587 return build3_v (COND_EXPR, tmp,
4588 null_expr, non_null_expr);
4592 return gfc_finish_block (&block);
4596 /* Assign a single component of a derived type constructor. */
4599 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4607 gfc_start_block (&block);
4609 if (cm->attr.pointer)
4611 gfc_init_se (&se, NULL);
4612 /* Pointer component. */
4613 if (cm->attr.dimension)
4615 /* Array pointer. */
4616 if (expr->expr_type == EXPR_NULL)
4617 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4620 rss = gfc_walk_expr (expr);
4621 se.direct_byref = 1;
4623 gfc_conv_expr_descriptor (&se, expr, rss);
4624 gfc_add_block_to_block (&block, &se.pre);
4625 gfc_add_block_to_block (&block, &se.post);
4630 /* Scalar pointers. */
4631 se.want_pointer = 1;
4632 gfc_conv_expr (&se, expr);
4633 gfc_add_block_to_block (&block, &se.pre);
4634 gfc_add_modify (&block, dest,
4635 fold_convert (TREE_TYPE (dest), se.expr));
4636 gfc_add_block_to_block (&block, &se.post);
4639 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4641 /* NULL initialization for CLASS components. */
4642 tmp = gfc_trans_structure_assign (dest,
4643 gfc_class_null_initializer (&cm->ts));
4644 gfc_add_expr_to_block (&block, tmp);
4646 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4648 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4649 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4650 else if (cm->attr.allocatable)
4652 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4653 gfc_add_expr_to_block (&block, tmp);
4657 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4658 gfc_add_expr_to_block (&block, tmp);
4661 else if (expr->ts.type == BT_DERIVED)
4663 if (expr->expr_type != EXPR_STRUCTURE)
4665 gfc_init_se (&se, NULL);
4666 gfc_conv_expr (&se, expr);
4667 gfc_add_block_to_block (&block, &se.pre);
4668 gfc_add_modify (&block, dest,
4669 fold_convert (TREE_TYPE (dest), se.expr));
4670 gfc_add_block_to_block (&block, &se.post);
4674 /* Nested constructors. */
4675 tmp = gfc_trans_structure_assign (dest, expr);
4676 gfc_add_expr_to_block (&block, tmp);
4681 /* Scalar component. */
4682 gfc_init_se (&se, NULL);
4683 gfc_init_se (&lse, NULL);
4685 gfc_conv_expr (&se, expr);
4686 if (cm->ts.type == BT_CHARACTER)
4687 lse.string_length = cm->ts.u.cl->backend_decl;
4689 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4690 gfc_add_expr_to_block (&block, tmp);
4692 return gfc_finish_block (&block);
4695 /* Assign a derived type constructor to a variable. */
4698 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4706 gfc_start_block (&block);
4707 cm = expr->ts.u.derived->components;
4709 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4710 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4711 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4715 gcc_assert (cm->backend_decl == NULL);
4716 gfc_init_se (&se, NULL);
4717 gfc_init_se (&lse, NULL);
4718 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4720 gfc_add_modify (&block, lse.expr,
4721 fold_convert (TREE_TYPE (lse.expr), se.expr));
4723 return gfc_finish_block (&block);
4726 for (c = gfc_constructor_first (expr->value.constructor);
4727 c; c = gfc_constructor_next (c), cm = cm->next)
4729 /* Skip absent members in default initializers. */
4733 field = cm->backend_decl;
4734 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4735 dest, field, NULL_TREE);
4736 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4737 gfc_add_expr_to_block (&block, tmp);
4739 return gfc_finish_block (&block);
4742 /* Build an expression for a constructor. If init is nonzero then
4743 this is part of a static variable initializer. */
4746 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4753 VEC(constructor_elt,gc) *v = NULL;
4755 gcc_assert (se->ss == NULL);
4756 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4757 type = gfc_typenode_for_spec (&expr->ts);
4761 /* Create a temporary variable and fill it in. */
4762 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4763 tmp = gfc_trans_structure_assign (se->expr, expr);
4764 gfc_add_expr_to_block (&se->pre, tmp);
4768 cm = expr->ts.u.derived->components;
4770 for (c = gfc_constructor_first (expr->value.constructor);
4771 c; c = gfc_constructor_next (c), cm = cm->next)
4773 /* Skip absent members in default initializers and allocatable
4774 components. Although the latter have a default initializer
4775 of EXPR_NULL,... by default, the static nullify is not needed
4776 since this is done every time we come into scope. */
4777 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4780 if (strcmp (cm->name, "_size") == 0)
4782 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4783 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4785 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4786 && strcmp (cm->name, "_extends") == 0)
4790 vtabs = cm->initializer->symtree->n.sym;
4791 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4792 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4796 val = gfc_conv_initializer (c->expr, &cm->ts,
4797 TREE_TYPE (cm->backend_decl),
4798 cm->attr.dimension, cm->attr.pointer,
4799 cm->attr.proc_pointer);
4801 /* Append it to the constructor list. */
4802 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4805 se->expr = build_constructor (type, v);
4807 TREE_CONSTANT (se->expr) = 1;
4811 /* Translate a substring expression. */
4814 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4820 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4822 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4823 expr->value.character.length,
4824 expr->value.character.string);
4826 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4827 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4830 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4834 /* Entry point for expression translation. Evaluates a scalar quantity.
4835 EXPR is the expression to be translated, and SE is the state structure if
4836 called from within the scalarized. */
4839 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4844 if (ss && ss->info->expr == expr
4845 && (ss->info->type == GFC_SS_SCALAR
4846 || ss->info->type == GFC_SS_REFERENCE))
4848 gfc_ss_info *ss_info;
4851 /* Substitute a scalar expression evaluated outside the scalarization
4853 se->expr = ss_info->data.scalar.value;
4854 if (ss_info->type == GFC_SS_REFERENCE)
4855 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4856 se->string_length = ss_info->string_length;
4857 gfc_advance_se_ss_chain (se);
4861 /* We need to convert the expressions for the iso_c_binding derived types.
4862 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4863 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4864 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4865 updated to be an integer with a kind equal to the size of a (void *). */
4866 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4867 && expr->ts.u.derived->attr.is_iso_c)
4869 if (expr->expr_type == EXPR_VARIABLE
4870 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4871 || expr->symtree->n.sym->intmod_sym_id
4872 == ISOCBINDING_NULL_FUNPTR))
4874 /* Set expr_type to EXPR_NULL, which will result in
4875 null_pointer_node being used below. */
4876 expr->expr_type = EXPR_NULL;
4880 /* Update the type/kind of the expression to be what the new
4881 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4882 expr->ts.type = expr->ts.u.derived->ts.type;
4883 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4884 expr->ts.kind = expr->ts.u.derived->ts.kind;
4888 switch (expr->expr_type)
4891 gfc_conv_expr_op (se, expr);
4895 gfc_conv_function_expr (se, expr);
4899 gfc_conv_constant (se, expr);
4903 gfc_conv_variable (se, expr);
4907 se->expr = null_pointer_node;
4910 case EXPR_SUBSTRING:
4911 gfc_conv_substring_expr (se, expr);
4914 case EXPR_STRUCTURE:
4915 gfc_conv_structure (se, expr, 0);
4919 gfc_conv_array_constructor_expr (se, expr);
4928 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4929 of an assignment. */
4931 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4933 gfc_conv_expr (se, expr);
4934 /* All numeric lvalues should have empty post chains. If not we need to
4935 figure out a way of rewriting an lvalue so that it has no post chain. */
4936 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4939 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4940 numeric expressions. Used for scalar values where inserting cleanup code
4943 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4947 gcc_assert (expr->ts.type != BT_CHARACTER);
4948 gfc_conv_expr (se, expr);
4951 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4952 gfc_add_modify (&se->pre, val, se->expr);
4954 gfc_add_block_to_block (&se->pre, &se->post);
4958 /* Helper to translate an expression and convert it to a particular type. */
4960 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4962 gfc_conv_expr_val (se, expr);
4963 se->expr = convert (type, se->expr);
4967 /* Converts an expression so that it can be passed by reference. Scalar
4971 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4977 if (ss && ss->info->expr == expr
4978 && ss->info->type == GFC_SS_REFERENCE)
4980 /* Returns a reference to the scalar evaluated outside the loop
4982 gfc_conv_expr (se, expr);
4986 if (expr->ts.type == BT_CHARACTER)
4988 gfc_conv_expr (se, expr);
4989 gfc_conv_string_parameter (se);
4993 if (expr->expr_type == EXPR_VARIABLE)
4995 se->want_pointer = 1;
4996 gfc_conv_expr (se, expr);
4999 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5000 gfc_add_modify (&se->pre, var, se->expr);
5001 gfc_add_block_to_block (&se->pre, &se->post);
5007 if (expr->expr_type == EXPR_FUNCTION
5008 && ((expr->value.function.esym
5009 && expr->value.function.esym->result->attr.pointer
5010 && !expr->value.function.esym->result->attr.dimension)
5011 || (!expr->value.function.esym
5012 && expr->symtree->n.sym->attr.pointer
5013 && !expr->symtree->n.sym->attr.dimension)))
5015 se->want_pointer = 1;
5016 gfc_conv_expr (se, expr);
5017 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5018 gfc_add_modify (&se->pre, var, se->expr);
5024 gfc_conv_expr (se, expr);
5026 /* Create a temporary var to hold the value. */
5027 if (TREE_CONSTANT (se->expr))
5029 tree tmp = se->expr;
5030 STRIP_TYPE_NOPS (tmp);
5031 var = build_decl (input_location,
5032 CONST_DECL, NULL, TREE_TYPE (tmp));
5033 DECL_INITIAL (var) = tmp;
5034 TREE_STATIC (var) = 1;
5039 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5040 gfc_add_modify (&se->pre, var, se->expr);
5042 gfc_add_block_to_block (&se->pre, &se->post);
5044 /* Take the address of that value. */
5045 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5050 gfc_trans_pointer_assign (gfc_code * code)
5052 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5056 /* Generate code for a pointer assignment. */
5059 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5070 gfc_start_block (&block);
5072 gfc_init_se (&lse, NULL);
5074 lss = gfc_walk_expr (expr1);
5075 rss = gfc_walk_expr (expr2);
5076 if (lss == gfc_ss_terminator)
5078 /* Scalar pointers. */
5079 lse.want_pointer = 1;
5080 gfc_conv_expr (&lse, expr1);
5081 gcc_assert (rss == gfc_ss_terminator);
5082 gfc_init_se (&rse, NULL);
5083 rse.want_pointer = 1;
5084 gfc_conv_expr (&rse, expr2);
5086 if (expr1->symtree->n.sym->attr.proc_pointer
5087 && expr1->symtree->n.sym->attr.dummy)
5088 lse.expr = build_fold_indirect_ref_loc (input_location,
5091 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5092 && expr2->symtree->n.sym->attr.dummy)
5093 rse.expr = build_fold_indirect_ref_loc (input_location,
5096 gfc_add_block_to_block (&block, &lse.pre);
5097 gfc_add_block_to_block (&block, &rse.pre);
5099 /* Check character lengths if character expression. The test is only
5100 really added if -fbounds-check is enabled. Exclude deferred
5101 character length lefthand sides. */
5102 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5103 && !(expr1->ts.deferred
5104 && (TREE_CODE (lse.string_length) == VAR_DECL))
5105 && !expr1->symtree->n.sym->attr.proc_pointer
5106 && !gfc_is_proc_ptr_comp (expr1, NULL))
5108 gcc_assert (expr2->ts.type == BT_CHARACTER);
5109 gcc_assert (lse.string_length && rse.string_length);
5110 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5111 lse.string_length, rse.string_length,
5115 /* The assignment to an deferred character length sets the string
5116 length to that of the rhs. */
5117 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5119 if (expr2->expr_type != EXPR_NULL)
5120 gfc_add_modify (&block, lse.string_length, rse.string_length);
5122 gfc_add_modify (&block, lse.string_length,
5123 build_int_cst (gfc_charlen_type_node, 0));
5126 gfc_add_modify (&block, lse.expr,
5127 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5129 gfc_add_block_to_block (&block, &rse.post);
5130 gfc_add_block_to_block (&block, &lse.post);
5137 tree strlen_rhs = NULL_TREE;
5139 /* Array pointer. Find the last reference on the LHS and if it is an
5140 array section ref, we're dealing with bounds remapping. In this case,
5141 set it to AR_FULL so that gfc_conv_expr_descriptor does
5142 not see it and process the bounds remapping afterwards explicitely. */
5143 for (remap = expr1->ref; remap; remap = remap->next)
5144 if (!remap->next && remap->type == REF_ARRAY
5145 && remap->u.ar.type == AR_SECTION)
5147 remap->u.ar.type = AR_FULL;
5150 rank_remap = (remap && remap->u.ar.end[0]);
5152 gfc_conv_expr_descriptor (&lse, expr1, lss);
5153 strlen_lhs = lse.string_length;
5156 if (expr2->expr_type == EXPR_NULL)
5158 /* Just set the data pointer to null. */
5159 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5161 else if (rank_remap)
5163 /* If we are rank-remapping, just get the RHS's descriptor and
5164 process this later on. */
5165 gfc_init_se (&rse, NULL);
5166 rse.direct_byref = 1;
5167 rse.byref_noassign = 1;
5168 gfc_conv_expr_descriptor (&rse, expr2, rss);
5169 strlen_rhs = rse.string_length;
5171 else if (expr2->expr_type == EXPR_VARIABLE)
5173 /* Assign directly to the LHS's descriptor. */
5174 lse.direct_byref = 1;
5175 gfc_conv_expr_descriptor (&lse, expr2, rss);
5176 strlen_rhs = lse.string_length;
5178 /* If this is a subreference array pointer assignment, use the rhs
5179 descriptor element size for the lhs span. */
5180 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5182 decl = expr1->symtree->n.sym->backend_decl;
5183 gfc_init_se (&rse, NULL);
5184 rse.descriptor_only = 1;
5185 gfc_conv_expr (&rse, expr2);
5186 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5187 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5188 if (!INTEGER_CST_P (tmp))
5189 gfc_add_block_to_block (&lse.post, &rse.pre);
5190 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5195 /* Assign to a temporary descriptor and then copy that
5196 temporary to the pointer. */
5197 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5200 lse.direct_byref = 1;
5201 gfc_conv_expr_descriptor (&lse, expr2, rss);
5202 strlen_rhs = lse.string_length;
5203 gfc_add_modify (&lse.pre, desc, tmp);
5206 gfc_add_block_to_block (&block, &lse.pre);
5208 gfc_add_block_to_block (&block, &rse.pre);
5210 /* If we do bounds remapping, update LHS descriptor accordingly. */
5214 gcc_assert (remap->u.ar.dimen == expr1->rank);
5218 /* Do rank remapping. We already have the RHS's descriptor
5219 converted in rse and now have to build the correct LHS
5220 descriptor for it. */
5224 tree lbound, ubound;
5227 dtype = gfc_conv_descriptor_dtype (desc);
5228 tmp = gfc_get_dtype (TREE_TYPE (desc));
5229 gfc_add_modify (&block, dtype, tmp);
5231 /* Copy data pointer. */
5232 data = gfc_conv_descriptor_data_get (rse.expr);
5233 gfc_conv_descriptor_data_set (&block, desc, data);
5235 /* Copy offset but adjust it such that it would correspond
5236 to a lbound of zero. */
5237 offs = gfc_conv_descriptor_offset_get (rse.expr);
5238 for (dim = 0; dim < expr2->rank; ++dim)
5240 stride = gfc_conv_descriptor_stride_get (rse.expr,
5242 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5244 tmp = fold_build2_loc (input_location, MULT_EXPR,
5245 gfc_array_index_type, stride, lbound);
5246 offs = fold_build2_loc (input_location, PLUS_EXPR,
5247 gfc_array_index_type, offs, tmp);
5249 gfc_conv_descriptor_offset_set (&block, desc, offs);
5251 /* Set the bounds as declared for the LHS and calculate strides as
5252 well as another offset update accordingly. */
5253 stride = gfc_conv_descriptor_stride_get (rse.expr,
5255 for (dim = 0; dim < expr1->rank; ++dim)
5260 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5262 /* Convert declared bounds. */
5263 gfc_init_se (&lower_se, NULL);
5264 gfc_init_se (&upper_se, NULL);
5265 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5266 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5268 gfc_add_block_to_block (&block, &lower_se.pre);
5269 gfc_add_block_to_block (&block, &upper_se.pre);
5271 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5272 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5274 lbound = gfc_evaluate_now (lbound, &block);
5275 ubound = gfc_evaluate_now (ubound, &block);
5277 gfc_add_block_to_block (&block, &lower_se.post);
5278 gfc_add_block_to_block (&block, &upper_se.post);
5280 /* Set bounds in descriptor. */
5281 gfc_conv_descriptor_lbound_set (&block, desc,
5282 gfc_rank_cst[dim], lbound);
5283 gfc_conv_descriptor_ubound_set (&block, desc,
5284 gfc_rank_cst[dim], ubound);
5287 stride = gfc_evaluate_now (stride, &block);
5288 gfc_conv_descriptor_stride_set (&block, desc,
5289 gfc_rank_cst[dim], stride);
5291 /* Update offset. */
5292 offs = gfc_conv_descriptor_offset_get (desc);
5293 tmp = fold_build2_loc (input_location, MULT_EXPR,
5294 gfc_array_index_type, lbound, stride);
5295 offs = fold_build2_loc (input_location, MINUS_EXPR,
5296 gfc_array_index_type, offs, tmp);
5297 offs = gfc_evaluate_now (offs, &block);
5298 gfc_conv_descriptor_offset_set (&block, desc, offs);
5300 /* Update stride. */
5301 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5302 stride = fold_build2_loc (input_location, MULT_EXPR,
5303 gfc_array_index_type, stride, tmp);
5308 /* Bounds remapping. Just shift the lower bounds. */
5310 gcc_assert (expr1->rank == expr2->rank);
5312 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5316 gcc_assert (remap->u.ar.start[dim]);
5317 gcc_assert (!remap->u.ar.end[dim]);
5318 gfc_init_se (&lbound_se, NULL);
5319 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5321 gfc_add_block_to_block (&block, &lbound_se.pre);
5322 gfc_conv_shift_descriptor_lbound (&block, desc,
5323 dim, lbound_se.expr);
5324 gfc_add_block_to_block (&block, &lbound_se.post);
5329 /* Check string lengths if applicable. The check is only really added
5330 to the output code if -fbounds-check is enabled. */
5331 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5333 gcc_assert (expr2->ts.type == BT_CHARACTER);
5334 gcc_assert (strlen_lhs && strlen_rhs);
5335 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5336 strlen_lhs, strlen_rhs, &block);
5339 /* If rank remapping was done, check with -fcheck=bounds that
5340 the target is at least as large as the pointer. */
5341 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5347 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5348 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5350 lsize = gfc_evaluate_now (lsize, &block);
5351 rsize = gfc_evaluate_now (rsize, &block);
5352 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5355 msg = _("Target of rank remapping is too small (%ld < %ld)");
5356 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5360 gfc_add_block_to_block (&block, &lse.post);
5362 gfc_add_block_to_block (&block, &rse.post);
5365 return gfc_finish_block (&block);
5369 /* Makes sure se is suitable for passing as a function string parameter. */
5370 /* TODO: Need to check all callers of this function. It may be abused. */
5373 gfc_conv_string_parameter (gfc_se * se)
5377 if (TREE_CODE (se->expr) == STRING_CST)
5379 type = TREE_TYPE (TREE_TYPE (se->expr));
5380 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5384 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5386 if (TREE_CODE (se->expr) != INDIRECT_REF)
5388 type = TREE_TYPE (se->expr);
5389 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5393 type = gfc_get_character_type_len (gfc_default_character_kind,
5395 type = build_pointer_type (type);
5396 se->expr = gfc_build_addr_expr (type, se->expr);
5400 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5404 /* Generate code for assignment of scalar variables. Includes character
5405 strings and derived types with allocatable components.
5406 If you know that the LHS has no allocations, set dealloc to false. */
5409 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5410 bool l_is_temp, bool r_is_var, bool dealloc)
5416 gfc_init_block (&block);
5418 if (ts.type == BT_CHARACTER)
5423 if (lse->string_length != NULL_TREE)
5425 gfc_conv_string_parameter (lse);
5426 gfc_add_block_to_block (&block, &lse->pre);
5427 llen = lse->string_length;
5430 if (rse->string_length != NULL_TREE)
5432 gcc_assert (rse->string_length != NULL_TREE);
5433 gfc_conv_string_parameter (rse);
5434 gfc_add_block_to_block (&block, &rse->pre);
5435 rlen = rse->string_length;
5438 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5439 rse->expr, ts.kind);
5441 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5445 /* Are the rhs and the lhs the same? */
5448 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5449 gfc_build_addr_expr (NULL_TREE, lse->expr),
5450 gfc_build_addr_expr (NULL_TREE, rse->expr));
5451 cond = gfc_evaluate_now (cond, &lse->pre);
5454 /* Deallocate the lhs allocated components as long as it is not
5455 the same as the rhs. This must be done following the assignment
5456 to prevent deallocating data that could be used in the rhs
5458 if (!l_is_temp && dealloc)
5460 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5461 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5463 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5465 gfc_add_expr_to_block (&lse->post, tmp);
5468 gfc_add_block_to_block (&block, &rse->pre);
5469 gfc_add_block_to_block (&block, &lse->pre);
5471 gfc_add_modify (&block, lse->expr,
5472 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5474 /* Do a deep copy if the rhs is a variable, if it is not the
5478 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5479 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5481 gfc_add_expr_to_block (&block, tmp);
5484 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5486 gfc_add_block_to_block (&block, &lse->pre);
5487 gfc_add_block_to_block (&block, &rse->pre);
5488 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5489 TREE_TYPE (lse->expr), rse->expr);
5490 gfc_add_modify (&block, lse->expr, tmp);
5494 gfc_add_block_to_block (&block, &lse->pre);
5495 gfc_add_block_to_block (&block, &rse->pre);
5497 gfc_add_modify (&block, lse->expr,
5498 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5501 gfc_add_block_to_block (&block, &lse->post);
5502 gfc_add_block_to_block (&block, &rse->post);
5504 return gfc_finish_block (&block);
5508 /* There are quite a lot of restrictions on the optimisation in using an
5509 array function assign without a temporary. */
5512 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5515 bool seen_array_ref;
5517 gfc_symbol *sym = expr1->symtree->n.sym;
5519 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5520 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5523 /* Elemental functions are scalarized so that they don't need a
5524 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5525 they would need special treatment in gfc_trans_arrayfunc_assign. */
5526 if (expr2->value.function.esym != NULL
5527 && expr2->value.function.esym->attr.elemental)
5530 /* Need a temporary if rhs is not FULL or a contiguous section. */
5531 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5534 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5535 if (gfc_ref_needs_temporary_p (expr1->ref))
5538 /* Functions returning pointers or allocatables need temporaries. */
5539 c = expr2->value.function.esym
5540 ? (expr2->value.function.esym->attr.pointer
5541 || expr2->value.function.esym->attr.allocatable)
5542 : (expr2->symtree->n.sym->attr.pointer
5543 || expr2->symtree->n.sym->attr.allocatable);
5547 /* Character array functions need temporaries unless the
5548 character lengths are the same. */
5549 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5551 if (expr1->ts.u.cl->length == NULL
5552 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5555 if (expr2->ts.u.cl->length == NULL
5556 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5559 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5560 expr2->ts.u.cl->length->value.integer) != 0)
5564 /* Check that no LHS component references appear during an array
5565 reference. This is needed because we do not have the means to
5566 span any arbitrary stride with an array descriptor. This check
5567 is not needed for the rhs because the function result has to be
5569 seen_array_ref = false;
5570 for (ref = expr1->ref; ref; ref = ref->next)
5572 if (ref->type == REF_ARRAY)
5573 seen_array_ref= true;
5574 else if (ref->type == REF_COMPONENT && seen_array_ref)
5578 /* Check for a dependency. */
5579 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5580 expr2->value.function.esym,
5581 expr2->value.function.actual,
5585 /* If we have reached here with an intrinsic function, we do not
5586 need a temporary except in the particular case that reallocation
5587 on assignment is active and the lhs is allocatable and a target. */
5588 if (expr2->value.function.isym)
5589 return (gfc_option.flag_realloc_lhs
5590 && sym->attr.allocatable
5591 && sym->attr.target);
5593 /* If the LHS is a dummy, we need a temporary if it is not
5595 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5598 /* If the lhs has been host_associated, is in common, a pointer or is
5599 a target and the function is not using a RESULT variable, aliasing
5600 can occur and a temporary is needed. */
5601 if ((sym->attr.host_assoc
5602 || sym->attr.in_common
5603 || sym->attr.pointer
5604 || sym->attr.cray_pointee
5605 || sym->attr.target)
5606 && expr2->symtree != NULL
5607 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5610 /* A PURE function can unconditionally be called without a temporary. */
5611 if (expr2->value.function.esym != NULL
5612 && expr2->value.function.esym->attr.pure)
5615 /* Implicit_pure functions are those which could legally be declared
5617 if (expr2->value.function.esym != NULL
5618 && expr2->value.function.esym->attr.implicit_pure)
5621 if (!sym->attr.use_assoc
5622 && !sym->attr.in_common
5623 && !sym->attr.pointer
5624 && !sym->attr.target
5625 && !sym->attr.cray_pointee
5626 && expr2->value.function.esym)
5628 /* A temporary is not needed if the function is not contained and
5629 the variable is local or host associated and not a pointer or
5631 if (!expr2->value.function.esym->attr.contained)
5634 /* A temporary is not needed if the lhs has never been host
5635 associated and the procedure is contained. */
5636 else if (!sym->attr.host_assoc)
5639 /* A temporary is not needed if the variable is local and not
5640 a pointer, a target or a result. */
5642 && expr2->value.function.esym->ns == sym->ns->parent)
5646 /* Default to temporary use. */
5651 /* Provide the loop info so that the lhs descriptor can be built for
5652 reallocatable assignments from extrinsic function calls. */
5655 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5658 /* Signal that the function call should not be made by
5659 gfc_conv_loop_setup. */
5660 se->ss->is_alloc_lhs = 1;
5661 gfc_init_loopinfo (loop);
5662 gfc_add_ss_to_loop (loop, *ss);
5663 gfc_add_ss_to_loop (loop, se->ss);
5664 gfc_conv_ss_startstride (loop);
5665 gfc_conv_loop_setup (loop, where);
5666 gfc_copy_loopinfo_to_se (se, loop);
5667 gfc_add_block_to_block (&se->pre, &loop->pre);
5668 gfc_add_block_to_block (&se->pre, &loop->post);
5669 se->ss->is_alloc_lhs = 0;
5673 /* For Assignment to a reallocatable lhs from intrinsic functions,
5674 replace the se.expr (ie. the result) with a temporary descriptor.
5675 Null the data field so that the library allocates space for the
5676 result. Free the data of the original descriptor after the function,
5677 in case it appears in an argument expression and transfer the
5678 result to the original descriptor. */
5681 fcncall_realloc_result (gfc_se *se, int rank)
5689 /* Use the allocation done by the library. Substitute the lhs
5690 descriptor with a copy, whose data field is nulled.*/
5691 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5692 /* Unallocated, the descriptor does not have a dtype. */
5693 tmp = gfc_conv_descriptor_dtype (desc);
5694 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5695 res_desc = gfc_evaluate_now (desc, &se->pre);
5696 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5697 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5699 /* Free the lhs after the function call and copy the result to
5700 the lhs descriptor. */
5701 tmp = gfc_conv_descriptor_data_get (desc);
5702 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5703 gfc_add_expr_to_block (&se->post, tmp);
5704 gfc_add_modify (&se->post, desc, res_desc);
5706 offset = gfc_index_zero_node;
5707 tmp = gfc_index_one_node;
5708 /* Now reset the bounds from zero based to unity based. */
5709 for (n = 0 ; n < rank; n++)
5711 /* Accumulate the offset. */
5712 offset = fold_build2_loc (input_location, MINUS_EXPR,
5713 gfc_array_index_type,
5715 /* Now do the bounds. */
5716 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5717 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5718 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5719 gfc_array_index_type,
5720 tmp, gfc_index_one_node);
5721 gfc_conv_descriptor_lbound_set (&se->post, desc,
5723 gfc_index_one_node);
5724 gfc_conv_descriptor_ubound_set (&se->post, desc,
5725 gfc_rank_cst[n], tmp);
5727 /* The extent for the next contribution to offset. */
5728 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5729 gfc_array_index_type,
5730 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5731 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5732 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5733 gfc_array_index_type,
5734 tmp, gfc_index_one_node);
5736 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5741 /* Try to translate array(:) = func (...), where func is a transformational
5742 array function, without using a temporary. Returns NULL if this isn't the
5746 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5750 gfc_component *comp = NULL;
5753 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5756 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5758 gcc_assert (expr2->value.function.isym
5759 || (gfc_is_proc_ptr_comp (expr2, &comp)
5760 && comp && comp->attr.dimension)
5761 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5762 && expr2->value.function.esym->result->attr.dimension));
5764 ss = gfc_walk_expr (expr1);
5765 gcc_assert (ss != gfc_ss_terminator);
5766 gfc_init_se (&se, NULL);
5767 gfc_start_block (&se.pre);
5768 se.want_pointer = 1;
5770 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5772 if (expr1->ts.type == BT_DERIVED
5773 && expr1->ts.u.derived->attr.alloc_comp)
5776 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5778 gfc_add_expr_to_block (&se.pre, tmp);
5781 se.direct_byref = 1;
5782 se.ss = gfc_walk_expr (expr2);
5783 gcc_assert (se.ss != gfc_ss_terminator);
5785 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5786 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5787 Clearly, this cannot be done for an allocatable function result, since
5788 the shape of the result is unknown and, in any case, the function must
5789 correctly take care of the reallocation internally. For intrinsic
5790 calls, the array data is freed and the library takes care of allocation.
5791 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5793 if (gfc_option.flag_realloc_lhs
5794 && gfc_is_reallocatable_lhs (expr1)
5795 && !gfc_expr_attr (expr1).codimension
5796 && !gfc_is_coindexed (expr1)
5797 && !(expr2->value.function.esym
5798 && expr2->value.function.esym->result->attr.allocatable))
5800 if (!expr2->value.function.isym)
5802 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5803 ss->is_alloc_lhs = 1;
5806 fcncall_realloc_result (&se, expr1->rank);
5809 gfc_conv_function_expr (&se, expr2);
5810 gfc_add_block_to_block (&se.pre, &se.post);
5812 return gfc_finish_block (&se.pre);
5816 /* Try to efficiently translate array(:) = 0. Return NULL if this
5820 gfc_trans_zero_assign (gfc_expr * expr)
5822 tree dest, len, type;
5826 sym = expr->symtree->n.sym;
5827 dest = gfc_get_symbol_decl (sym);
5829 type = TREE_TYPE (dest);
5830 if (POINTER_TYPE_P (type))
5831 type = TREE_TYPE (type);
5832 if (!GFC_ARRAY_TYPE_P (type))
5835 /* Determine the length of the array. */
5836 len = GFC_TYPE_ARRAY_SIZE (type);
5837 if (!len || TREE_CODE (len) != INTEGER_CST)
5840 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5841 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5842 fold_convert (gfc_array_index_type, tmp));
5844 /* If we are zeroing a local array avoid taking its address by emitting
5846 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5847 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5848 dest, build_constructor (TREE_TYPE (dest), NULL));
5850 /* Convert arguments to the correct types. */
5851 dest = fold_convert (pvoid_type_node, dest);
5852 len = fold_convert (size_type_node, len);
5854 /* Construct call to __builtin_memset. */
5855 tmp = build_call_expr_loc (input_location,
5856 builtin_decl_explicit (BUILT_IN_MEMSET),
5857 3, dest, integer_zero_node, len);
5858 return fold_convert (void_type_node, tmp);
5862 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5863 that constructs the call to __builtin_memcpy. */
5866 gfc_build_memcpy_call (tree dst, tree src, tree len)
5870 /* Convert arguments to the correct types. */
5871 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5872 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5874 dst = fold_convert (pvoid_type_node, dst);
5876 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5877 src = gfc_build_addr_expr (pvoid_type_node, src);
5879 src = fold_convert (pvoid_type_node, src);
5881 len = fold_convert (size_type_node, len);
5883 /* Construct call to __builtin_memcpy. */
5884 tmp = build_call_expr_loc (input_location,
5885 builtin_decl_explicit (BUILT_IN_MEMCPY),
5887 return fold_convert (void_type_node, tmp);
5891 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5892 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5893 source/rhs, both are gfc_full_array_ref_p which have been checked for
5897 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5899 tree dst, dlen, dtype;
5900 tree src, slen, stype;
5903 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5904 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5906 dtype = TREE_TYPE (dst);
5907 if (POINTER_TYPE_P (dtype))
5908 dtype = TREE_TYPE (dtype);
5909 stype = TREE_TYPE (src);
5910 if (POINTER_TYPE_P (stype))
5911 stype = TREE_TYPE (stype);
5913 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5916 /* Determine the lengths of the arrays. */
5917 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5918 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5920 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5921 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5922 dlen, fold_convert (gfc_array_index_type, tmp));
5924 slen = GFC_TYPE_ARRAY_SIZE (stype);
5925 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5927 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5928 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5929 slen, fold_convert (gfc_array_index_type, tmp));
5931 /* Sanity check that they are the same. This should always be
5932 the case, as we should already have checked for conformance. */
5933 if (!tree_int_cst_equal (slen, dlen))
5936 return gfc_build_memcpy_call (dst, src, dlen);
5940 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5941 this can't be done. EXPR1 is the destination/lhs for which
5942 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5945 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5947 unsigned HOST_WIDE_INT nelem;
5953 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5957 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5958 dtype = TREE_TYPE (dst);
5959 if (POINTER_TYPE_P (dtype))
5960 dtype = TREE_TYPE (dtype);
5961 if (!GFC_ARRAY_TYPE_P (dtype))
5964 /* Determine the lengths of the array. */
5965 len = GFC_TYPE_ARRAY_SIZE (dtype);
5966 if (!len || TREE_CODE (len) != INTEGER_CST)
5969 /* Confirm that the constructor is the same size. */
5970 if (compare_tree_int (len, nelem) != 0)
5973 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5974 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5975 fold_convert (gfc_array_index_type, tmp));
5977 stype = gfc_typenode_for_spec (&expr2->ts);
5978 src = gfc_build_constant_array_constructor (expr2, stype);
5980 stype = TREE_TYPE (src);
5981 if (POINTER_TYPE_P (stype))
5982 stype = TREE_TYPE (stype);
5984 return gfc_build_memcpy_call (dst, src, len);
5988 /* Tells whether the expression is to be treated as a variable reference. */
5991 expr_is_variable (gfc_expr *expr)
5995 if (expr->expr_type == EXPR_VARIABLE)
5998 arg = gfc_get_noncopying_intrinsic_argument (expr);
6001 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6002 return expr_is_variable (arg);
6009 /* Is the lhs OK for automatic reallocation? */
6012 is_scalar_reallocatable_lhs (gfc_expr *expr)
6016 /* An allocatable variable with no reference. */
6017 if (expr->symtree->n.sym->attr.allocatable
6021 /* All that can be left are allocatable components. */
6022 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6023 && expr->symtree->n.sym->ts.type != BT_CLASS)
6024 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6027 /* Find an allocatable component ref last. */
6028 for (ref = expr->ref; ref; ref = ref->next)
6029 if (ref->type == REF_COMPONENT
6031 && ref->u.c.component->attr.allocatable)
6038 /* Allocate or reallocate scalar lhs, as necessary. */
6041 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6055 if (!expr1 || expr1->rank)
6058 if (!expr2 || expr2->rank)
6061 /* Since this is a scalar lhs, we can afford to do this. That is,
6062 there is no risk of side effects being repeated. */
6063 gfc_init_se (&lse, NULL);
6064 lse.want_pointer = 1;
6065 gfc_conv_expr (&lse, expr1);
6067 jump_label1 = gfc_build_label_decl (NULL_TREE);
6068 jump_label2 = gfc_build_label_decl (NULL_TREE);
6070 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6071 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6072 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6074 tmp = build3_v (COND_EXPR, cond,
6075 build1_v (GOTO_EXPR, jump_label1),
6076 build_empty_stmt (input_location));
6077 gfc_add_expr_to_block (block, tmp);
6079 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6081 /* Use the rhs string length and the lhs element size. */
6082 size = string_length;
6083 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6084 tmp = TYPE_SIZE_UNIT (tmp);
6085 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6086 TREE_TYPE (tmp), tmp,
6087 fold_convert (TREE_TYPE (tmp), size));
6091 /* Otherwise use the length in bytes of the rhs. */
6092 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6093 size_in_bytes = size;
6096 tmp = build_call_expr_loc (input_location,
6097 builtin_decl_explicit (BUILT_IN_MALLOC),
6099 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6100 gfc_add_modify (block, lse.expr, tmp);
6101 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6103 /* Deferred characters need checking for lhs and rhs string
6104 length. Other deferred parameter variables will have to
6106 tmp = build1_v (GOTO_EXPR, jump_label2);
6107 gfc_add_expr_to_block (block, tmp);
6109 tmp = build1_v (LABEL_EXPR, jump_label1);
6110 gfc_add_expr_to_block (block, tmp);
6112 /* For a deferred length character, reallocate if lengths of lhs and
6113 rhs are different. */
6114 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6116 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6117 expr1->ts.u.cl->backend_decl, size);
6118 /* Jump past the realloc if the lengths are the same. */
6119 tmp = build3_v (COND_EXPR, cond,
6120 build1_v (GOTO_EXPR, jump_label2),
6121 build_empty_stmt (input_location));
6122 gfc_add_expr_to_block (block, tmp);
6123 tmp = build_call_expr_loc (input_location,
6124 builtin_decl_explicit (BUILT_IN_REALLOC),
6125 2, fold_convert (pvoid_type_node, lse.expr),
6127 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6128 gfc_add_modify (block, lse.expr, tmp);
6129 tmp = build1_v (LABEL_EXPR, jump_label2);
6130 gfc_add_expr_to_block (block, tmp);
6132 /* Update the lhs character length. */
6133 size = string_length;
6134 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6139 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6140 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6141 init_flag indicates initialization expressions and dealloc that no
6142 deallocate prior assignment is needed (if in doubt, set true). */
6145 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6151 gfc_ss *lss_section;
6158 bool scalar_to_array;
6163 /* Assignment of the form lhs = rhs. */
6164 gfc_start_block (&block);
6166 gfc_init_se (&lse, NULL);
6167 gfc_init_se (&rse, NULL);
6170 lss = gfc_walk_expr (expr1);
6171 if (gfc_is_reallocatable_lhs (expr1)
6172 && !(expr2->expr_type == EXPR_FUNCTION
6173 && expr2->value.function.isym != NULL))
6174 lss->is_alloc_lhs = 1;
6176 if (lss != gfc_ss_terminator)
6178 /* The assignment needs scalarization. */
6181 /* Find a non-scalar SS from the lhs. */
6182 while (lss_section != gfc_ss_terminator
6183 && lss_section->info->type != GFC_SS_SECTION)
6184 lss_section = lss_section->next;
6186 gcc_assert (lss_section != gfc_ss_terminator);
6188 /* Initialize the scalarizer. */
6189 gfc_init_loopinfo (&loop);
6192 rss = gfc_walk_expr (expr2);
6193 if (rss == gfc_ss_terminator)
6194 /* The rhs is scalar. Add a ss for the expression. */
6195 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6197 /* Associate the SS with the loop. */
6198 gfc_add_ss_to_loop (&loop, lss);
6199 gfc_add_ss_to_loop (&loop, rss);
6201 /* Calculate the bounds of the scalarization. */
6202 gfc_conv_ss_startstride (&loop);
6203 /* Enable loop reversal. */
6204 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6205 loop.reverse[n] = GFC_ENABLE_REVERSE;
6206 /* Resolve any data dependencies in the statement. */
6207 gfc_conv_resolve_dependencies (&loop, lss, rss);
6208 /* Setup the scalarizing loops. */
6209 gfc_conv_loop_setup (&loop, &expr2->where);
6211 /* Setup the gfc_se structures. */
6212 gfc_copy_loopinfo_to_se (&lse, &loop);
6213 gfc_copy_loopinfo_to_se (&rse, &loop);
6216 gfc_mark_ss_chain_used (rss, 1);
6217 if (loop.temp_ss == NULL)
6220 gfc_mark_ss_chain_used (lss, 1);
6224 lse.ss = loop.temp_ss;
6225 gfc_mark_ss_chain_used (lss, 3);
6226 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6229 /* Allow the scalarizer to workshare array assignments. */
6230 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6231 ompws_flags |= OMPWS_SCALARIZER_WS;
6233 /* Start the scalarized loop body. */
6234 gfc_start_scalarized_body (&loop, &body);
6237 gfc_init_block (&body);
6239 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6241 /* Translate the expression. */
6242 gfc_conv_expr (&rse, expr2);
6244 /* Stabilize a string length for temporaries. */
6245 if (expr2->ts.type == BT_CHARACTER)
6246 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6248 string_length = NULL_TREE;
6252 gfc_conv_tmp_array_ref (&lse);
6253 if (expr2->ts.type == BT_CHARACTER)
6254 lse.string_length = string_length;
6257 gfc_conv_expr (&lse, expr1);
6259 /* Assignments of scalar derived types with allocatable components
6260 to arrays must be done with a deep copy and the rhs temporary
6261 must have its components deallocated afterwards. */
6262 scalar_to_array = (expr2->ts.type == BT_DERIVED
6263 && expr2->ts.u.derived->attr.alloc_comp
6264 && !expr_is_variable (expr2)
6265 && !gfc_is_constant_expr (expr2)
6266 && expr1->rank && !expr2->rank);
6267 if (scalar_to_array && dealloc)
6269 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6270 gfc_add_expr_to_block (&loop.post, tmp);
6273 /* For a deferred character length function, the function call must
6274 happen before the (re)allocation of the lhs, otherwise the character
6275 length of the result is not known. */
6276 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6277 || (expr2->expr_type == EXPR_COMPCALL)
6278 || (expr2->expr_type == EXPR_PPC))
6279 && expr2->ts.deferred);
6280 if (gfc_option.flag_realloc_lhs
6281 && expr2->ts.type == BT_CHARACTER
6282 && (def_clen_func || expr2->expr_type == EXPR_OP)
6283 && expr1->ts.deferred)
6284 gfc_add_block_to_block (&block, &rse.pre);
6286 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6287 l_is_temp || init_flag,
6288 expr_is_variable (expr2) || scalar_to_array
6289 || expr2->expr_type == EXPR_ARRAY, dealloc);
6290 gfc_add_expr_to_block (&body, tmp);
6292 if (lss == gfc_ss_terminator)
6294 /* F2003: Add the code for reallocation on assignment. */
6295 if (gfc_option.flag_realloc_lhs
6296 && is_scalar_reallocatable_lhs (expr1))
6297 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6300 /* Use the scalar assignment as is. */
6301 gfc_add_block_to_block (&block, &body);
6305 gcc_assert (lse.ss == gfc_ss_terminator
6306 && rse.ss == gfc_ss_terminator);
6310 gfc_trans_scalarized_loop_boundary (&loop, &body);
6312 /* We need to copy the temporary to the actual lhs. */
6313 gfc_init_se (&lse, NULL);
6314 gfc_init_se (&rse, NULL);
6315 gfc_copy_loopinfo_to_se (&lse, &loop);
6316 gfc_copy_loopinfo_to_se (&rse, &loop);
6318 rse.ss = loop.temp_ss;
6321 gfc_conv_tmp_array_ref (&rse);
6322 gfc_conv_expr (&lse, expr1);
6324 gcc_assert (lse.ss == gfc_ss_terminator
6325 && rse.ss == gfc_ss_terminator);
6327 if (expr2->ts.type == BT_CHARACTER)
6328 rse.string_length = string_length;
6330 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6331 false, false, dealloc);
6332 gfc_add_expr_to_block (&body, tmp);
6335 /* F2003: Allocate or reallocate lhs of allocatable array. */
6336 if (gfc_option.flag_realloc_lhs
6337 && gfc_is_reallocatable_lhs (expr1)
6338 && !gfc_expr_attr (expr1).codimension
6339 && !gfc_is_coindexed (expr1))
6341 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6342 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6343 if (tmp != NULL_TREE)
6344 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6347 /* Generate the copying loops. */
6348 gfc_trans_scalarizing_loops (&loop, &body);
6350 /* Wrap the whole thing up. */
6351 gfc_add_block_to_block (&block, &loop.pre);
6352 gfc_add_block_to_block (&block, &loop.post);
6354 gfc_cleanup_loop (&loop);
6357 return gfc_finish_block (&block);
6361 /* Check whether EXPR is a copyable array. */
6364 copyable_array_p (gfc_expr * expr)
6366 if (expr->expr_type != EXPR_VARIABLE)
6369 /* First check it's an array. */
6370 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6373 if (!gfc_full_array_ref_p (expr->ref, NULL))
6376 /* Next check that it's of a simple enough type. */
6377 switch (expr->ts.type)
6389 return !expr->ts.u.derived->attr.alloc_comp;
6398 /* Translate an assignment. */
6401 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6406 /* Special case a single function returning an array. */
6407 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6409 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6414 /* Special case assigning an array to zero. */
6415 if (copyable_array_p (expr1)
6416 && is_zero_initializer_p (expr2))
6418 tmp = gfc_trans_zero_assign (expr1);
6423 /* Special case copying one array to another. */
6424 if (copyable_array_p (expr1)
6425 && copyable_array_p (expr2)
6426 && gfc_compare_types (&expr1->ts, &expr2->ts)
6427 && !gfc_check_dependency (expr1, expr2, 0))
6429 tmp = gfc_trans_array_copy (expr1, expr2);
6434 /* Special case initializing an array from a constant array constructor. */
6435 if (copyable_array_p (expr1)
6436 && expr2->expr_type == EXPR_ARRAY
6437 && gfc_compare_types (&expr1->ts, &expr2->ts))
6439 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6444 /* Fallback to the scalarizer to generate explicit loops. */
6445 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6449 gfc_trans_init_assign (gfc_code * code)
6451 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6455 gfc_trans_assign (gfc_code * code)
6457 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6461 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6462 A MEMCPY is needed to copy the full data from the default initializer
6463 of the dynamic type. */
6466 gfc_trans_class_init_assign (gfc_code *code)
6470 gfc_se dst,src,memsz;
6471 gfc_expr *lhs,*rhs,*sz;
6473 gfc_start_block (&block);
6475 lhs = gfc_copy_expr (code->expr1);
6476 gfc_add_data_component (lhs);
6478 rhs = gfc_copy_expr (code->expr1);
6479 gfc_add_vptr_component (rhs);
6481 /* Make sure that the component backend_decls have been built, which
6482 will not have happened if the derived types concerned have not
6484 gfc_get_derived_type (rhs->ts.u.derived);
6485 gfc_add_def_init_component (rhs);
6487 sz = gfc_copy_expr (code->expr1);
6488 gfc_add_vptr_component (sz);
6489 gfc_add_size_component (sz);
6491 gfc_init_se (&dst, NULL);
6492 gfc_init_se (&src, NULL);
6493 gfc_init_se (&memsz, NULL);
6494 gfc_conv_expr (&dst, lhs);
6495 gfc_conv_expr (&src, rhs);
6496 gfc_conv_expr (&memsz, sz);
6497 gfc_add_block_to_block (&block, &src.pre);
6498 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6499 gfc_add_expr_to_block (&block, tmp);
6501 return gfc_finish_block (&block);
6505 /* Translate an assignment to a CLASS object
6506 (pointer or ordinary assignment). */
6509 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6516 gfc_start_block (&block);
6518 if (expr2->ts.type != BT_CLASS)
6520 /* Insert an additional assignment which sets the '_vptr' field. */
6521 gfc_symbol *vtab = NULL;
6524 lhs = gfc_copy_expr (expr1);
6525 gfc_add_vptr_component (lhs);
6527 if (expr2->ts.type == BT_DERIVED)
6528 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6529 else if (expr2->expr_type == EXPR_NULL)
6530 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6533 rhs = gfc_get_expr ();
6534 rhs->expr_type = EXPR_VARIABLE;
6535 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6539 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6540 gfc_add_expr_to_block (&block, tmp);
6542 gfc_free_expr (lhs);
6543 gfc_free_expr (rhs);
6546 /* Do the actual CLASS assignment. */
6547 if (expr2->ts.type == BT_CLASS)
6550 gfc_add_data_component (expr1);
6552 if (op == EXEC_ASSIGN)
6553 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6554 else if (op == EXEC_POINTER_ASSIGN)
6555 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6559 gfc_add_expr_to_block (&block, tmp);
6561 return gfc_finish_block (&block);