1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym->attr.pointer && !sym->attr.allocatable
148 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
149 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
152 tmp = build_fold_indirect_ref_loc (input_location, decl);
153 tmp = gfc_conv_array_data (tmp);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 fold_convert (TREE_TYPE (tmp), null_pointer_node));
156 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
157 boolean_type_node, cond, tmp);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
172 present = gfc_conv_expr_present (arg->symtree->n.sym);
176 /* Create a temporary and convert it to the correct type. */
177 tmp = gfc_get_int_type (kind);
178 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
181 /* Test for a NULL value. */
182 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
183 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
189 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
191 build_zero_cst (TREE_TYPE (se->expr)));
192 tmp = gfc_evaluate_now (tmp, &se->pre);
196 if (ts.type == BT_CHARACTER)
198 tmp = build_int_cst (gfc_charlen_type_node, 0);
199 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
200 present, se->string_length, tmp);
201 tmp = gfc_evaluate_now (tmp, &se->pre);
202 se->string_length = tmp;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr *e)
217 gcc_assert (e->expr_type == EXPR_VARIABLE
218 && e->ts.type == BT_CHARACTER);
220 length = NULL; /* To silence compiler warning. */
222 if (is_subref_array (e) && e->ts.u.cl->length)
225 gfc_init_se (&tmpse, NULL);
226 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
227 e->ts.u.cl->backend_decl = tmpse.expr;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
235 length = e->symtree->n.sym->ts.u.cl->backend_decl;
237 /* Look through the reference chain for component references. */
238 for (r = e->ref; r; r = r->next)
243 if (r->u.c.component->ts.type == BT_CHARACTER)
244 length = r->u.c.component->ts.u.cl->backend_decl;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length != NULL);
264 /* For each character array constructor subexpression without a ts.u.cl->length,
265 replace it by its first element (if there aren't any elements, the length
266 should already be set to zero). */
269 flatten_array_ctors_without_strlen (gfc_expr* e)
271 gfc_actual_arglist* arg;
277 switch (e->expr_type)
281 flatten_array_ctors_without_strlen (e->value.op.op1);
282 flatten_array_ctors_without_strlen (e->value.op.op2);
286 /* TODO: Implement as with EXPR_FUNCTION when needed. */
290 for (arg = e->value.function.actual; arg; arg = arg->next)
291 flatten_array_ctors_without_strlen (arg->expr);
296 /* We've found what we're looking for. */
297 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
302 gcc_assert (e->value.constructor);
304 c = gfc_constructor_first (e->value.constructor);
308 flatten_array_ctors_without_strlen (new_expr);
309 gfc_replace_expr (e, new_expr);
313 /* Otherwise, fall through to handle constructor elements. */
315 for (c = gfc_constructor_first (e->value.constructor);
316 c; c = gfc_constructor_next (c))
317 flatten_array_ctors_without_strlen (c->expr);
327 /* Generate code to initialize a string length variable. Returns the
328 value. For array constructors, cl->length might be NULL and in this case,
329 the first element of the constructor is needed. expr is the original
330 expression so we can access it but can be NULL if this is not needed. */
333 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
337 gfc_init_se (&se, NULL);
341 && TREE_CODE (cl->backend_decl) == VAR_DECL)
344 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
345 "flatten" array constructors by taking their first element; all elements
346 should be the same length or a cl->length should be present. */
351 expr_flat = gfc_copy_expr (expr);
352 flatten_array_ctors_without_strlen (expr_flat);
353 gfc_resolve_expr (expr_flat);
355 gfc_conv_expr (&se, expr_flat);
356 gfc_add_block_to_block (pblock, &se.pre);
357 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
359 gfc_free_expr (expr_flat);
363 /* Convert cl->length. */
365 gcc_assert (cl->length);
367 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
368 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
369 se.expr, build_int_cst (gfc_charlen_type_node, 0));
370 gfc_add_block_to_block (pblock, &se.pre);
372 if (cl->backend_decl)
373 gfc_add_modify (pblock, cl->backend_decl, se.expr);
375 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
380 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
381 const char *name, locus *where)
390 type = gfc_get_character_type (kind, ref->u.ss.length);
391 type = build_pointer_type (type);
393 gfc_init_se (&start, se);
394 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
395 gfc_add_block_to_block (&se->pre, &start.pre);
397 if (integer_onep (start.expr))
398 gfc_conv_string_parameter (se);
403 /* Avoid multiple evaluation of substring start. */
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 start.expr = gfc_evaluate_now (start.expr, &se->pre);
407 /* Change the start of the string. */
408 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
411 tmp = build_fold_indirect_ref_loc (input_location,
413 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
414 se->expr = gfc_build_addr_expr (type, tmp);
417 /* Length = end + 1 - start. */
418 gfc_init_se (&end, se);
419 if (ref->u.ss.end == NULL)
420 end.expr = se->string_length;
423 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
424 gfc_add_block_to_block (&se->pre, &end.pre);
428 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
429 end.expr = gfc_evaluate_now (end.expr, &se->pre);
431 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
433 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
434 boolean_type_node, start.expr,
437 /* Check lower bound. */
438 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
440 build_int_cst (gfc_charlen_type_node, 1));
441 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
442 boolean_type_node, nonempty, fault);
444 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
445 "is less than one", name);
447 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
449 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
450 fold_convert (long_integer_type_node,
454 /* Check upper bound. */
455 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
456 end.expr, se->string_length);
457 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
458 boolean_type_node, nonempty, fault);
460 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
461 "exceeds string length (%%ld)", name);
463 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
464 "exceeds string length (%%ld)");
465 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
466 fold_convert (long_integer_type_node, end.expr),
467 fold_convert (long_integer_type_node,
472 /* If the start and end expressions are equal, the length is one. */
474 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
475 tmp = build_int_cst (gfc_charlen_type_node, 1);
478 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
479 end.expr, start.expr);
480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
481 build_int_cst (gfc_charlen_type_node, 1), tmp);
482 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
483 tmp, build_int_cst (gfc_charlen_type_node, 0));
486 se->string_length = tmp;
490 /* Convert a derived type component reference. */
493 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
500 c = ref->u.c.component;
502 gcc_assert (c->backend_decl);
504 field = c->backend_decl;
505 gcc_assert (TREE_CODE (field) == FIELD_DECL);
508 /* Components can correspond to fields of different containing
509 types, as components are created without context, whereas
510 a concrete use of a component has the type of decl as context.
511 So, if the type doesn't match, we search the corresponding
512 FIELD_DECL in the parent type. To not waste too much time
513 we cache this result in norestrict_decl. */
515 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
517 tree f2 = c->norestrict_decl;
518 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
519 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
520 if (TREE_CODE (f2) == FIELD_DECL
521 && DECL_NAME (f2) == DECL_NAME (field))
524 c->norestrict_decl = f2;
527 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
528 decl, field, NULL_TREE);
532 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
534 tmp = c->ts.u.cl->backend_decl;
535 /* Components must always be constant length. */
536 gcc_assert (tmp && INTEGER_CST_P (tmp));
537 se->string_length = tmp;
540 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
541 && c->ts.type != BT_CHARACTER)
542 || c->attr.proc_pointer)
543 se->expr = build_fold_indirect_ref_loc (input_location,
548 /* This function deals with component references to components of the
549 parent type for derived type extensons. */
551 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
559 c = ref->u.c.component;
561 /* Return if the component is not in the parent type. */
562 for (cmp = dt->components; cmp; cmp = cmp->next)
563 if (strcmp (c->name, cmp->name) == 0)
566 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
567 parent.type = REF_COMPONENT;
570 parent.u.c.component = dt->components;
572 if (dt->backend_decl == NULL)
573 gfc_get_derived_type (dt);
575 /* Build the reference and call self. */
576 gfc_conv_component_ref (se, &parent);
577 parent.u.c.sym = dt->components->ts.u.derived;
578 parent.u.c.component = c;
579 conv_parent_component_references (se, &parent);
582 /* Return the contents of a variable. Also handles reference/pointer
583 variables (all Fortran pointer references are implicit). */
586 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
590 tree parent_decl = NULL_TREE;
593 bool alternate_entry;
596 sym = expr->symtree->n.sym;
599 /* Check that something hasn't gone horribly wrong. */
600 gcc_assert (se->ss != gfc_ss_terminator);
601 gcc_assert (se->ss->expr == expr);
603 /* A scalarized term. We already know the descriptor. */
604 se->expr = se->ss->data.info.descriptor;
605 se->string_length = se->ss->string_length;
606 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
607 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
612 tree se_expr = NULL_TREE;
614 se->expr = gfc_get_symbol_decl (sym);
616 /* Deal with references to a parent results or entries by storing
617 the current_function_decl and moving to the parent_decl. */
618 return_value = sym->attr.function && sym->result == sym;
619 alternate_entry = sym->attr.function && sym->attr.entry
620 && sym->result == sym;
621 entry_master = sym->attr.result
622 && sym->ns->proc_name->attr.entry_master
623 && !gfc_return_by_reference (sym->ns->proc_name);
624 if (current_function_decl)
625 parent_decl = DECL_CONTEXT (current_function_decl);
627 if ((se->expr == parent_decl && return_value)
628 || (sym->ns && sym->ns->proc_name
630 && sym->ns->proc_name->backend_decl == parent_decl
631 && (alternate_entry || entry_master)))
636 /* Special case for assigning the return value of a function.
637 Self recursive functions must have an explicit return value. */
638 if (return_value && (se->expr == current_function_decl || parent_flag))
639 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
641 /* Similarly for alternate entry points. */
642 else if (alternate_entry
643 && (sym->ns->proc_name->backend_decl == current_function_decl
646 gfc_entry_list *el = NULL;
648 for (el = sym->ns->entries; el; el = el->next)
651 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
656 else if (entry_master
657 && (sym->ns->proc_name->backend_decl == current_function_decl
659 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
664 /* Procedure actual arguments. */
665 else if (sym->attr.flavor == FL_PROCEDURE
666 && se->expr != current_function_decl)
668 if (!sym->attr.dummy && !sym->attr.proc_pointer)
670 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
671 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
677 /* Dereference the expression, where needed. Since characters
678 are entirely different from other types, they are treated
680 if (sym->ts.type == BT_CHARACTER)
682 /* Dereference character pointer dummy arguments
684 if ((sym->attr.pointer || sym->attr.allocatable)
686 || sym->attr.function
687 || sym->attr.result))
688 se->expr = build_fold_indirect_ref_loc (input_location,
692 else if (!sym->attr.value)
694 /* Dereference non-character scalar dummy arguments. */
695 if (sym->attr.dummy && !sym->attr.dimension)
696 se->expr = build_fold_indirect_ref_loc (input_location,
699 /* Dereference scalar hidden result. */
700 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
701 && (sym->attr.function || sym->attr.result)
702 && !sym->attr.dimension && !sym->attr.pointer
703 && !sym->attr.always_explicit)
704 se->expr = build_fold_indirect_ref_loc (input_location,
707 /* Dereference non-character pointer variables.
708 These must be dummies, results, or scalars. */
709 if ((sym->attr.pointer || sym->attr.allocatable
710 || gfc_is_associate_pointer (sym))
712 || sym->attr.function
714 || !sym->attr.dimension))
715 se->expr = build_fold_indirect_ref_loc (input_location,
722 /* For character variables, also get the length. */
723 if (sym->ts.type == BT_CHARACTER)
725 /* If the character length of an entry isn't set, get the length from
726 the master function instead. */
727 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
728 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
730 se->string_length = sym->ts.u.cl->backend_decl;
731 gcc_assert (se->string_length);
739 /* Return the descriptor if that's what we want and this is an array
740 section reference. */
741 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
743 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
744 /* Return the descriptor for array pointers and allocations. */
746 && ref->next == NULL && (se->descriptor_only))
749 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
750 /* Return a pointer to an element. */
754 if (ref->u.c.sym->attr.extension)
755 conv_parent_component_references (se, ref);
757 gfc_conv_component_ref (se, ref);
761 gfc_conv_substring (se, ref, expr->ts.kind,
762 expr->symtree->name, &expr->where);
771 /* Pointer assignment, allocation or pass by reference. Arrays are handled
773 if (se->want_pointer)
775 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
776 gfc_conv_string_parameter (se);
778 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
783 /* Unary ops are easy... Or they would be if ! was a valid op. */
786 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
791 gcc_assert (expr->ts.type != BT_CHARACTER);
792 /* Initialize the operand. */
793 gfc_init_se (&operand, se);
794 gfc_conv_expr_val (&operand, expr->value.op.op1);
795 gfc_add_block_to_block (&se->pre, &operand.pre);
797 type = gfc_typenode_for_spec (&expr->ts);
799 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
800 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
801 All other unary operators have an equivalent GIMPLE unary operator. */
802 if (code == TRUTH_NOT_EXPR)
803 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
804 build_int_cst (type, 0));
806 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
810 /* Expand power operator to optimal multiplications when a value is raised
811 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
812 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
813 Programming", 3rd Edition, 1998. */
815 /* This code is mostly duplicated from expand_powi in the backend.
816 We establish the "optimal power tree" lookup table with the defined size.
817 The items in the table are the exponents used to calculate the index
818 exponents. Any integer n less than the value can get an "addition chain",
819 with the first node being one. */
820 #define POWI_TABLE_SIZE 256
822 /* The table is from builtins.c. */
823 static const unsigned char powi_table[POWI_TABLE_SIZE] =
825 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
826 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
827 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
828 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
829 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
830 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
831 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
832 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
833 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
834 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
835 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
836 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
837 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
838 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
839 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
840 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
841 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
842 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
843 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
844 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
845 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
846 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
847 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
848 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
849 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
850 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
851 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
852 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
853 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
854 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
855 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
856 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
859 /* If n is larger than lookup table's max index, we use the "window
861 #define POWI_WINDOW_SIZE 3
863 /* Recursive function to expand the power operator. The temporary
864 values are put in tmpvar. The function returns tmpvar[1] ** n. */
866 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
873 if (n < POWI_TABLE_SIZE)
878 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
879 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
883 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
884 op0 = gfc_conv_powi (se, n - digit, tmpvar);
885 op1 = gfc_conv_powi (se, digit, tmpvar);
889 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
893 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
894 tmp = gfc_evaluate_now (tmp, &se->pre);
896 if (n < POWI_TABLE_SIZE)
903 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
904 return 1. Else return 0 and a call to runtime library functions
905 will have to be built. */
907 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
912 tree vartmp[POWI_TABLE_SIZE];
914 unsigned HOST_WIDE_INT n;
917 /* If exponent is too large, we won't expand it anyway, so don't bother
918 with large integer values. */
919 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
922 m = double_int_to_shwi (TREE_INT_CST (rhs));
923 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
924 of the asymmetric range of the integer type. */
925 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
927 type = TREE_TYPE (lhs);
928 sgn = tree_int_cst_sgn (rhs);
930 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
931 || optimize_size) && (m > 2 || m < -1))
937 se->expr = gfc_build_const (type, integer_one_node);
941 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
942 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
944 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
945 lhs, build_int_cst (TREE_TYPE (lhs), -1));
946 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
947 lhs, build_int_cst (TREE_TYPE (lhs), 1));
950 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
953 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
954 boolean_type_node, tmp, cond);
955 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
956 tmp, build_int_cst (type, 1),
957 build_int_cst (type, 0));
961 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
962 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
963 build_int_cst (type, -1),
964 build_int_cst (type, 0));
965 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
966 cond, build_int_cst (type, 1), tmp);
970 memset (vartmp, 0, sizeof (vartmp));
974 tmp = gfc_build_const (type, integer_one_node);
975 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
979 se->expr = gfc_conv_powi (se, n, vartmp);
985 /* Power op (**). Constant integer exponent has special handling. */
988 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
990 tree gfc_int4_type_node;
993 int res_ikind_1, res_ikind_2;
998 gfc_init_se (&lse, se);
999 gfc_conv_expr_val (&lse, expr->value.op.op1);
1000 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1001 gfc_add_block_to_block (&se->pre, &lse.pre);
1003 gfc_init_se (&rse, se);
1004 gfc_conv_expr_val (&rse, expr->value.op.op2);
1005 gfc_add_block_to_block (&se->pre, &rse.pre);
1007 if (expr->value.op.op2->ts.type == BT_INTEGER
1008 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1009 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1012 gfc_int4_type_node = gfc_get_int_type (4);
1014 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1015 library routine. But in the end, we have to convert the result back
1016 if this case applies -- with res_ikind_K, we keep track whether operand K
1017 falls into this case. */
1021 kind = expr->value.op.op1->ts.kind;
1022 switch (expr->value.op.op2->ts.type)
1025 ikind = expr->value.op.op2->ts.kind;
1030 rse.expr = convert (gfc_int4_type_node, rse.expr);
1031 res_ikind_2 = ikind;
1053 if (expr->value.op.op1->ts.type == BT_INTEGER)
1055 lse.expr = convert (gfc_int4_type_node, lse.expr);
1082 switch (expr->value.op.op1->ts.type)
1085 if (kind == 3) /* Case 16 was not handled properly above. */
1087 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1091 /* Use builtins for real ** int4. */
1097 fndecl = built_in_decls[BUILT_IN_POWIF];
1101 fndecl = built_in_decls[BUILT_IN_POWI];
1105 fndecl = built_in_decls[BUILT_IN_POWIL];
1109 /* Use the __builtin_powil() only if real(kind=16) is
1110 actually the C long double type. */
1111 if (!gfc_real16_is_float128)
1112 fndecl = built_in_decls[BUILT_IN_POWIL];
1120 /* If we don't have a good builtin for this, go for the
1121 library function. */
1123 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1127 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1136 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1140 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1148 se->expr = build_call_expr_loc (input_location,
1149 fndecl, 2, lse.expr, rse.expr);
1151 /* Convert the result back if it is of wrong integer kind. */
1152 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1154 /* We want the maximum of both operand kinds as result. */
1155 if (res_ikind_1 < res_ikind_2)
1156 res_ikind_1 = res_ikind_2;
1157 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1162 /* Generate code to allocate a string temporary. */
1165 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1170 if (gfc_can_put_var_on_stack (len))
1172 /* Create a temporary variable to hold the result. */
1173 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1174 gfc_charlen_type_node, len,
1175 build_int_cst (gfc_charlen_type_node, 1));
1176 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1178 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1179 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1181 tmp = build_array_type (TREE_TYPE (type), tmp);
1183 var = gfc_create_var (tmp, "str");
1184 var = gfc_build_addr_expr (type, var);
1188 /* Allocate a temporary to hold the result. */
1189 var = gfc_create_var (type, "pstr");
1190 tmp = gfc_call_malloc (&se->pre, type,
1191 fold_build2_loc (input_location, MULT_EXPR,
1192 TREE_TYPE (len), len,
1193 fold_convert (TREE_TYPE (len),
1194 TYPE_SIZE (type))));
1195 gfc_add_modify (&se->pre, var, tmp);
1197 /* Free the temporary afterwards. */
1198 tmp = gfc_call_free (convert (pvoid_type_node, var));
1199 gfc_add_expr_to_block (&se->post, tmp);
1206 /* Handle a string concatenation operation. A temporary will be allocated to
1210 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1213 tree len, type, var, tmp, fndecl;
1215 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1216 && expr->value.op.op2->ts.type == BT_CHARACTER);
1217 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1219 gfc_init_se (&lse, se);
1220 gfc_conv_expr (&lse, expr->value.op.op1);
1221 gfc_conv_string_parameter (&lse);
1222 gfc_init_se (&rse, se);
1223 gfc_conv_expr (&rse, expr->value.op.op2);
1224 gfc_conv_string_parameter (&rse);
1226 gfc_add_block_to_block (&se->pre, &lse.pre);
1227 gfc_add_block_to_block (&se->pre, &rse.pre);
1229 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1230 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1231 if (len == NULL_TREE)
1233 len = fold_build2_loc (input_location, PLUS_EXPR,
1234 TREE_TYPE (lse.string_length),
1235 lse.string_length, rse.string_length);
1238 type = build_pointer_type (type);
1240 var = gfc_conv_string_tmp (se, type, len);
1242 /* Do the actual concatenation. */
1243 if (expr->ts.kind == 1)
1244 fndecl = gfor_fndecl_concat_string;
1245 else if (expr->ts.kind == 4)
1246 fndecl = gfor_fndecl_concat_string_char4;
1250 tmp = build_call_expr_loc (input_location,
1251 fndecl, 6, len, var, lse.string_length, lse.expr,
1252 rse.string_length, rse.expr);
1253 gfc_add_expr_to_block (&se->pre, tmp);
1255 /* Add the cleanup for the operands. */
1256 gfc_add_block_to_block (&se->pre, &rse.post);
1257 gfc_add_block_to_block (&se->pre, &lse.post);
1260 se->string_length = len;
1263 /* Translates an op expression. Common (binary) cases are handled by this
1264 function, others are passed on. Recursion is used in either case.
1265 We use the fact that (op1.ts == op2.ts) (except for the power
1267 Operators need no special handling for scalarized expressions as long as
1268 they call gfc_conv_simple_val to get their operands.
1269 Character strings get special handling. */
1272 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1274 enum tree_code code;
1283 switch (expr->value.op.op)
1285 case INTRINSIC_PARENTHESES:
1286 if ((expr->ts.type == BT_REAL
1287 || expr->ts.type == BT_COMPLEX)
1288 && gfc_option.flag_protect_parens)
1290 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1291 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1296 case INTRINSIC_UPLUS:
1297 gfc_conv_expr (se, expr->value.op.op1);
1300 case INTRINSIC_UMINUS:
1301 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1305 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1308 case INTRINSIC_PLUS:
1312 case INTRINSIC_MINUS:
1316 case INTRINSIC_TIMES:
1320 case INTRINSIC_DIVIDE:
1321 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1322 an integer, we must round towards zero, so we use a
1324 if (expr->ts.type == BT_INTEGER)
1325 code = TRUNC_DIV_EXPR;
1330 case INTRINSIC_POWER:
1331 gfc_conv_power_op (se, expr);
1334 case INTRINSIC_CONCAT:
1335 gfc_conv_concat_op (se, expr);
1339 code = TRUTH_ANDIF_EXPR;
1344 code = TRUTH_ORIF_EXPR;
1348 /* EQV and NEQV only work on logicals, but since we represent them
1349 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1351 case INTRINSIC_EQ_OS:
1359 case INTRINSIC_NE_OS:
1360 case INTRINSIC_NEQV:
1367 case INTRINSIC_GT_OS:
1374 case INTRINSIC_GE_OS:
1381 case INTRINSIC_LT_OS:
1388 case INTRINSIC_LE_OS:
1394 case INTRINSIC_USER:
1395 case INTRINSIC_ASSIGN:
1396 /* These should be converted into function calls by the frontend. */
1400 fatal_error ("Unknown intrinsic op");
1404 /* The only exception to this is **, which is handled separately anyway. */
1405 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1407 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1411 gfc_init_se (&lse, se);
1412 gfc_conv_expr (&lse, expr->value.op.op1);
1413 gfc_add_block_to_block (&se->pre, &lse.pre);
1416 gfc_init_se (&rse, se);
1417 gfc_conv_expr (&rse, expr->value.op.op2);
1418 gfc_add_block_to_block (&se->pre, &rse.pre);
1422 gfc_conv_string_parameter (&lse);
1423 gfc_conv_string_parameter (&rse);
1425 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1426 rse.string_length, rse.expr,
1427 expr->value.op.op1->ts.kind,
1429 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1430 gfc_add_block_to_block (&lse.post, &rse.post);
1433 type = gfc_typenode_for_spec (&expr->ts);
1437 /* The result of logical ops is always boolean_type_node. */
1438 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1439 lse.expr, rse.expr);
1440 se->expr = convert (type, tmp);
1443 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1445 /* Add the post blocks. */
1446 gfc_add_block_to_block (&se->post, &rse.post);
1447 gfc_add_block_to_block (&se->post, &lse.post);
1450 /* If a string's length is one, we convert it to a single character. */
1453 gfc_string_to_single_character (tree len, tree str, int kind)
1456 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1457 || !POINTER_TYPE_P (TREE_TYPE (str)))
1460 if (TREE_INT_CST_LOW (len) == 1)
1462 str = fold_convert (gfc_get_pchar_type (kind), str);
1463 return build_fold_indirect_ref_loc (input_location, str);
1467 && TREE_CODE (str) == ADDR_EXPR
1468 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1469 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1470 && array_ref_low_bound (TREE_OPERAND (str, 0))
1471 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1472 && TREE_INT_CST_LOW (len) > 1
1473 && TREE_INT_CST_LOW (len)
1474 == (unsigned HOST_WIDE_INT)
1475 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1477 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1478 ret = build_fold_indirect_ref_loc (input_location, ret);
1479 if (TREE_CODE (ret) == INTEGER_CST)
1481 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1482 int i, length = TREE_STRING_LENGTH (string_cst);
1483 const char *ptr = TREE_STRING_POINTER (string_cst);
1485 for (i = 1; i < length; i++)
1498 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1501 if (sym->backend_decl)
1503 /* This becomes the nominal_type in
1504 function.c:assign_parm_find_data_types. */
1505 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1506 /* This becomes the passed_type in
1507 function.c:assign_parm_find_data_types. C promotes char to
1508 integer for argument passing. */
1509 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1511 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1516 /* If we have a constant character expression, make it into an
1518 if ((*expr)->expr_type == EXPR_CONSTANT)
1523 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1524 (int)(*expr)->value.character.string[0]);
1525 if ((*expr)->ts.kind != gfc_c_int_kind)
1527 /* The expr needs to be compatible with a C int. If the
1528 conversion fails, then the 2 causes an ICE. */
1529 ts.type = BT_INTEGER;
1530 ts.kind = gfc_c_int_kind;
1531 gfc_convert_type (*expr, &ts, 2);
1534 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1536 if ((*expr)->ref == NULL)
1538 se->expr = gfc_string_to_single_character
1539 (build_int_cst (integer_type_node, 1),
1540 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1542 ((*expr)->symtree->n.sym)),
1547 gfc_conv_variable (se, *expr);
1548 se->expr = gfc_string_to_single_character
1549 (build_int_cst (integer_type_node, 1),
1550 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1558 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1559 if STR is a string literal, otherwise return -1. */
1562 gfc_optimize_len_trim (tree len, tree str, int kind)
1565 && TREE_CODE (str) == ADDR_EXPR
1566 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1567 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1568 && array_ref_low_bound (TREE_OPERAND (str, 0))
1569 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1570 && TREE_INT_CST_LOW (len) >= 1
1571 && TREE_INT_CST_LOW (len)
1572 == (unsigned HOST_WIDE_INT)
1573 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1575 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1576 folded = build_fold_indirect_ref_loc (input_location, folded);
1577 if (TREE_CODE (folded) == INTEGER_CST)
1579 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1580 int length = TREE_STRING_LENGTH (string_cst);
1581 const char *ptr = TREE_STRING_POINTER (string_cst);
1583 for (; length > 0; length--)
1584 if (ptr[length - 1] != ' ')
1593 /* Compare two strings. If they are all single characters, the result is the
1594 subtraction of them. Otherwise, we build a library call. */
1597 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1598 enum tree_code code)
1604 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1605 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1607 sc1 = gfc_string_to_single_character (len1, str1, kind);
1608 sc2 = gfc_string_to_single_character (len2, str2, kind);
1610 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1612 /* Deal with single character specially. */
1613 sc1 = fold_convert (integer_type_node, sc1);
1614 sc2 = fold_convert (integer_type_node, sc2);
1615 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1619 if ((code == EQ_EXPR || code == NE_EXPR)
1621 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1623 /* If one string is a string literal with LEN_TRIM longer
1624 than the length of the second string, the strings
1626 int len = gfc_optimize_len_trim (len1, str1, kind);
1627 if (len > 0 && compare_tree_int (len2, len) < 0)
1628 return integer_one_node;
1629 len = gfc_optimize_len_trim (len2, str2, kind);
1630 if (len > 0 && compare_tree_int (len1, len) < 0)
1631 return integer_one_node;
1634 /* Build a call for the comparison. */
1636 fndecl = gfor_fndecl_compare_string;
1638 fndecl = gfor_fndecl_compare_string_char4;
1642 return build_call_expr_loc (input_location, fndecl, 4,
1643 len1, str1, len2, str2);
1647 /* Return the backend_decl for a procedure pointer component. */
1650 get_proc_ptr_comp (gfc_expr *e)
1656 gfc_init_se (&comp_se, NULL);
1657 e2 = gfc_copy_expr (e);
1658 /* We have to restore the expr type later so that gfc_free_expr frees
1659 the exact same thing that was allocated.
1660 TODO: This is ugly. */
1661 old_type = e2->expr_type;
1662 e2->expr_type = EXPR_VARIABLE;
1663 gfc_conv_expr (&comp_se, e2);
1664 e2->expr_type = old_type;
1666 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1671 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1675 if (gfc_is_proc_ptr_comp (expr, NULL))
1676 tmp = get_proc_ptr_comp (expr);
1677 else if (sym->attr.dummy)
1679 tmp = gfc_get_symbol_decl (sym);
1680 if (sym->attr.proc_pointer)
1681 tmp = build_fold_indirect_ref_loc (input_location,
1683 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1684 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1688 if (!sym->backend_decl)
1689 sym->backend_decl = gfc_get_extern_function_decl (sym);
1691 tmp = sym->backend_decl;
1693 if (sym->attr.cray_pointee)
1695 /* TODO - make the cray pointee a pointer to a procedure,
1696 assign the pointer to it and use it for the call. This
1698 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1699 gfc_get_symbol_decl (sym->cp_pointer));
1700 tmp = gfc_evaluate_now (tmp, &se->pre);
1703 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1705 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1706 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1713 /* Initialize MAPPING. */
1716 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1718 mapping->syms = NULL;
1719 mapping->charlens = NULL;
1723 /* Free all memory held by MAPPING (but not MAPPING itself). */
1726 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1728 gfc_interface_sym_mapping *sym;
1729 gfc_interface_sym_mapping *nextsym;
1731 gfc_charlen *nextcl;
1733 for (sym = mapping->syms; sym; sym = nextsym)
1735 nextsym = sym->next;
1736 sym->new_sym->n.sym->formal = NULL;
1737 gfc_free_symbol (sym->new_sym->n.sym);
1738 gfc_free_expr (sym->expr);
1739 free (sym->new_sym);
1742 for (cl = mapping->charlens; cl; cl = nextcl)
1745 gfc_free_expr (cl->length);
1751 /* Return a copy of gfc_charlen CL. Add the returned structure to
1752 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1754 static gfc_charlen *
1755 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1758 gfc_charlen *new_charlen;
1760 new_charlen = gfc_get_charlen ();
1761 new_charlen->next = mapping->charlens;
1762 new_charlen->length = gfc_copy_expr (cl->length);
1764 mapping->charlens = new_charlen;
1769 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1770 array variable that can be used as the actual argument for dummy
1771 argument SYM. Add any initialization code to BLOCK. PACKED is as
1772 for gfc_get_nodesc_array_type and DATA points to the first element
1773 in the passed array. */
1776 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1777 gfc_packed packed, tree data)
1782 type = gfc_typenode_for_spec (&sym->ts);
1783 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1784 !sym->attr.target && !sym->attr.pointer
1785 && !sym->attr.proc_pointer);
1787 var = gfc_create_var (type, "ifm");
1788 gfc_add_modify (block, var, fold_convert (type, data));
1794 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1795 and offset of descriptorless array type TYPE given that it has the same
1796 size as DESC. Add any set-up code to BLOCK. */
1799 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1806 offset = gfc_index_zero_node;
1807 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1809 dim = gfc_rank_cst[n];
1810 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1811 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1813 GFC_TYPE_ARRAY_LBOUND (type, n)
1814 = gfc_conv_descriptor_lbound_get (desc, dim);
1815 GFC_TYPE_ARRAY_UBOUND (type, n)
1816 = gfc_conv_descriptor_ubound_get (desc, dim);
1818 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1820 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1821 gfc_array_index_type,
1822 gfc_conv_descriptor_ubound_get (desc, dim),
1823 gfc_conv_descriptor_lbound_get (desc, dim));
1824 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1825 gfc_array_index_type,
1826 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1827 tmp = gfc_evaluate_now (tmp, block);
1828 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1830 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1831 GFC_TYPE_ARRAY_LBOUND (type, n),
1832 GFC_TYPE_ARRAY_STRIDE (type, n));
1833 offset = fold_build2_loc (input_location, MINUS_EXPR,
1834 gfc_array_index_type, offset, tmp);
1836 offset = gfc_evaluate_now (offset, block);
1837 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1841 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1842 in SE. The caller may still use se->expr and se->string_length after
1843 calling this function. */
1846 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1847 gfc_symbol * sym, gfc_se * se,
1850 gfc_interface_sym_mapping *sm;
1854 gfc_symbol *new_sym;
1856 gfc_symtree *new_symtree;
1858 /* Create a new symbol to represent the actual argument. */
1859 new_sym = gfc_new_symbol (sym->name, NULL);
1860 new_sym->ts = sym->ts;
1861 new_sym->as = gfc_copy_array_spec (sym->as);
1862 new_sym->attr.referenced = 1;
1863 new_sym->attr.dimension = sym->attr.dimension;
1864 new_sym->attr.contiguous = sym->attr.contiguous;
1865 new_sym->attr.codimension = sym->attr.codimension;
1866 new_sym->attr.pointer = sym->attr.pointer;
1867 new_sym->attr.allocatable = sym->attr.allocatable;
1868 new_sym->attr.flavor = sym->attr.flavor;
1869 new_sym->attr.function = sym->attr.function;
1871 /* Ensure that the interface is available and that
1872 descriptors are passed for array actual arguments. */
1873 if (sym->attr.flavor == FL_PROCEDURE)
1875 new_sym->formal = expr->symtree->n.sym->formal;
1876 new_sym->attr.always_explicit
1877 = expr->symtree->n.sym->attr.always_explicit;
1880 /* Create a fake symtree for it. */
1882 new_symtree = gfc_new_symtree (&root, sym->name);
1883 new_symtree->n.sym = new_sym;
1884 gcc_assert (new_symtree == root);
1886 /* Create a dummy->actual mapping. */
1887 sm = XCNEW (gfc_interface_sym_mapping);
1888 sm->next = mapping->syms;
1890 sm->new_sym = new_symtree;
1891 sm->expr = gfc_copy_expr (expr);
1894 /* Stabilize the argument's value. */
1895 if (!sym->attr.function && se)
1896 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1898 if (sym->ts.type == BT_CHARACTER)
1900 /* Create a copy of the dummy argument's length. */
1901 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1902 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1904 /* If the length is specified as "*", record the length that
1905 the caller is passing. We should use the callee's length
1906 in all other cases. */
1907 if (!new_sym->ts.u.cl->length && se)
1909 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1910 new_sym->ts.u.cl->backend_decl = se->string_length;
1917 /* Use the passed value as-is if the argument is a function. */
1918 if (sym->attr.flavor == FL_PROCEDURE)
1921 /* If the argument is either a string or a pointer to a string,
1922 convert it to a boundless character type. */
1923 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1925 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1926 tmp = build_pointer_type (tmp);
1927 if (sym->attr.pointer)
1928 value = build_fold_indirect_ref_loc (input_location,
1932 value = fold_convert (tmp, value);
1935 /* If the argument is a scalar, a pointer to an array or an allocatable,
1937 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1938 value = build_fold_indirect_ref_loc (input_location,
1941 /* For character(*), use the actual argument's descriptor. */
1942 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1943 value = build_fold_indirect_ref_loc (input_location,
1946 /* If the argument is an array descriptor, use it to determine
1947 information about the actual argument's shape. */
1948 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1949 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1951 /* Get the actual argument's descriptor. */
1952 desc = build_fold_indirect_ref_loc (input_location,
1955 /* Create the replacement variable. */
1956 tmp = gfc_conv_descriptor_data_get (desc);
1957 value = gfc_get_interface_mapping_array (&se->pre, sym,
1960 /* Use DESC to work out the upper bounds, strides and offset. */
1961 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1964 /* Otherwise we have a packed array. */
1965 value = gfc_get_interface_mapping_array (&se->pre, sym,
1966 PACKED_FULL, se->expr);
1968 new_sym->backend_decl = value;
1972 /* Called once all dummy argument mappings have been added to MAPPING,
1973 but before the mapping is used to evaluate expressions. Pre-evaluate
1974 the length of each argument, adding any initialization code to PRE and
1975 any finalization code to POST. */
1978 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1979 stmtblock_t * pre, stmtblock_t * post)
1981 gfc_interface_sym_mapping *sym;
1985 for (sym = mapping->syms; sym; sym = sym->next)
1986 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1987 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1989 expr = sym->new_sym->n.sym->ts.u.cl->length;
1990 gfc_apply_interface_mapping_to_expr (mapping, expr);
1991 gfc_init_se (&se, NULL);
1992 gfc_conv_expr (&se, expr);
1993 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1994 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1995 gfc_add_block_to_block (pre, &se.pre);
1996 gfc_add_block_to_block (post, &se.post);
1998 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2003 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2007 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2008 gfc_constructor_base base)
2011 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2013 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2016 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2017 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2018 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2024 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2028 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2033 for (; ref; ref = ref->next)
2037 for (n = 0; n < ref->u.ar.dimen; n++)
2039 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2040 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2041 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2043 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2050 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2051 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2057 /* Convert intrinsic function calls into result expressions. */
2060 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2068 arg1 = expr->value.function.actual->expr;
2069 if (expr->value.function.actual->next)
2070 arg2 = expr->value.function.actual->next->expr;
2074 sym = arg1->symtree->n.sym;
2076 if (sym->attr.dummy)
2081 switch (expr->value.function.isym->id)
2084 /* TODO figure out why this condition is necessary. */
2085 if (sym->attr.function
2086 && (arg1->ts.u.cl->length == NULL
2087 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2088 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2091 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2095 if (!sym->as || sym->as->rank == 0)
2098 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2100 dup = mpz_get_si (arg2->value.integer);
2105 dup = sym->as->rank;
2109 for (; d < dup; d++)
2113 if (!sym->as->upper[d] || !sym->as->lower[d])
2115 gfc_free_expr (new_expr);
2119 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2120 gfc_get_int_expr (gfc_default_integer_kind,
2122 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2124 new_expr = gfc_multiply (new_expr, tmp);
2130 case GFC_ISYM_LBOUND:
2131 case GFC_ISYM_UBOUND:
2132 /* TODO These implementations of lbound and ubound do not limit if
2133 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2135 if (!sym->as || sym->as->rank == 0)
2138 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2139 d = mpz_get_si (arg2->value.integer) - 1;
2141 /* TODO: If the need arises, this could produce an array of
2145 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2147 if (sym->as->lower[d])
2148 new_expr = gfc_copy_expr (sym->as->lower[d]);
2152 if (sym->as->upper[d])
2153 new_expr = gfc_copy_expr (sym->as->upper[d]);
2161 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2165 gfc_replace_expr (expr, new_expr);
2171 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2172 gfc_interface_mapping * mapping)
2174 gfc_formal_arglist *f;
2175 gfc_actual_arglist *actual;
2177 actual = expr->value.function.actual;
2178 f = map_expr->symtree->n.sym->formal;
2180 for (; f && actual; f = f->next, actual = actual->next)
2185 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2188 if (map_expr->symtree->n.sym->attr.dimension)
2193 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2195 for (d = 0; d < as->rank; d++)
2197 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2198 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2201 expr->value.function.esym->as = as;
2204 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2206 expr->value.function.esym->ts.u.cl->length
2207 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2209 gfc_apply_interface_mapping_to_expr (mapping,
2210 expr->value.function.esym->ts.u.cl->length);
2215 /* EXPR is a copy of an expression that appeared in the interface
2216 associated with MAPPING. Walk it recursively looking for references to
2217 dummy arguments that MAPPING maps to actual arguments. Replace each such
2218 reference with a reference to the associated actual argument. */
2221 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2224 gfc_interface_sym_mapping *sym;
2225 gfc_actual_arglist *actual;
2230 /* Copying an expression does not copy its length, so do that here. */
2231 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2233 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2234 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2237 /* Apply the mapping to any references. */
2238 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2240 /* ...and to the expression's symbol, if it has one. */
2241 /* TODO Find out why the condition on expr->symtree had to be moved into
2242 the loop rather than being outside it, as originally. */
2243 for (sym = mapping->syms; sym; sym = sym->next)
2244 if (expr->symtree && sym->old == expr->symtree->n.sym)
2246 if (sym->new_sym->n.sym->backend_decl)
2247 expr->symtree = sym->new_sym;
2249 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2250 /* Replace base type for polymorphic arguments. */
2251 if (expr->ref && expr->ref->type == REF_COMPONENT
2252 && sym->expr && sym->expr->ts.type == BT_CLASS)
2253 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2256 /* ...and to subexpressions in expr->value. */
2257 switch (expr->expr_type)
2262 case EXPR_SUBSTRING:
2266 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2267 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2271 for (actual = expr->value.function.actual; actual; actual = actual->next)
2272 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2274 if (expr->value.function.esym == NULL
2275 && expr->value.function.isym != NULL
2276 && expr->value.function.actual->expr->symtree
2277 && gfc_map_intrinsic_function (expr, mapping))
2280 for (sym = mapping->syms; sym; sym = sym->next)
2281 if (sym->old == expr->value.function.esym)
2283 expr->value.function.esym = sym->new_sym->n.sym;
2284 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2285 expr->value.function.esym->result = sym->new_sym->n.sym;
2290 case EXPR_STRUCTURE:
2291 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2304 /* Evaluate interface expression EXPR using MAPPING. Store the result
2308 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2309 gfc_se * se, gfc_expr * expr)
2311 expr = gfc_copy_expr (expr);
2312 gfc_apply_interface_mapping_to_expr (mapping, expr);
2313 gfc_conv_expr (se, expr);
2314 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2315 gfc_free_expr (expr);
2319 /* Returns a reference to a temporary array into which a component of
2320 an actual argument derived type array is copied and then returned
2321 after the function call. */
2323 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2324 sym_intent intent, bool formal_ptr)
2342 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2344 gfc_init_se (&lse, NULL);
2345 gfc_init_se (&rse, NULL);
2347 /* Walk the argument expression. */
2348 rss = gfc_walk_expr (expr);
2350 gcc_assert (rss != gfc_ss_terminator);
2352 /* Initialize the scalarizer. */
2353 gfc_init_loopinfo (&loop);
2354 gfc_add_ss_to_loop (&loop, rss);
2356 /* Calculate the bounds of the scalarization. */
2357 gfc_conv_ss_startstride (&loop);
2359 /* Build an ss for the temporary. */
2360 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2361 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2363 base_type = gfc_typenode_for_spec (&expr->ts);
2364 if (GFC_ARRAY_TYPE_P (base_type)
2365 || GFC_DESCRIPTOR_TYPE_P (base_type))
2366 base_type = gfc_get_element_type (base_type);
2368 loop.temp_ss = gfc_get_ss ();;
2369 loop.temp_ss->type = GFC_SS_TEMP;
2370 loop.temp_ss->data.temp.type = base_type;
2372 if (expr->ts.type == BT_CHARACTER)
2373 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2375 loop.temp_ss->string_length = NULL;
2377 parmse->string_length = loop.temp_ss->string_length;
2378 loop.temp_ss->data.temp.dimen = loop.dimen;
2379 loop.temp_ss->next = gfc_ss_terminator;
2381 /* Associate the SS with the loop. */
2382 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2384 /* Setup the scalarizing loops. */
2385 gfc_conv_loop_setup (&loop, &expr->where);
2387 /* Pass the temporary descriptor back to the caller. */
2388 info = &loop.temp_ss->data.info;
2389 parmse->expr = info->descriptor;
2391 /* Setup the gfc_se structures. */
2392 gfc_copy_loopinfo_to_se (&lse, &loop);
2393 gfc_copy_loopinfo_to_se (&rse, &loop);
2396 lse.ss = loop.temp_ss;
2397 gfc_mark_ss_chain_used (rss, 1);
2398 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2400 /* Start the scalarized loop body. */
2401 gfc_start_scalarized_body (&loop, &body);
2403 /* Translate the expression. */
2404 gfc_conv_expr (&rse, expr);
2406 gfc_conv_tmp_array_ref (&lse);
2408 if (intent != INTENT_OUT)
2410 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2411 gfc_add_expr_to_block (&body, tmp);
2412 gcc_assert (rse.ss == gfc_ss_terminator);
2413 gfc_trans_scalarizing_loops (&loop, &body);
2417 /* Make sure that the temporary declaration survives by merging
2418 all the loop declarations into the current context. */
2419 for (n = 0; n < loop.dimen; n++)
2421 gfc_merge_block_scope (&body);
2422 body = loop.code[loop.order[n]];
2424 gfc_merge_block_scope (&body);
2427 /* Add the post block after the second loop, so that any
2428 freeing of allocated memory is done at the right time. */
2429 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2431 /**********Copy the temporary back again.*********/
2433 gfc_init_se (&lse, NULL);
2434 gfc_init_se (&rse, NULL);
2436 /* Walk the argument expression. */
2437 lss = gfc_walk_expr (expr);
2438 rse.ss = loop.temp_ss;
2441 /* Initialize the scalarizer. */
2442 gfc_init_loopinfo (&loop2);
2443 gfc_add_ss_to_loop (&loop2, lss);
2445 /* Calculate the bounds of the scalarization. */
2446 gfc_conv_ss_startstride (&loop2);
2448 /* Setup the scalarizing loops. */
2449 gfc_conv_loop_setup (&loop2, &expr->where);
2451 gfc_copy_loopinfo_to_se (&lse, &loop2);
2452 gfc_copy_loopinfo_to_se (&rse, &loop2);
2454 gfc_mark_ss_chain_used (lss, 1);
2455 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2457 /* Declare the variable to hold the temporary offset and start the
2458 scalarized loop body. */
2459 offset = gfc_create_var (gfc_array_index_type, NULL);
2460 gfc_start_scalarized_body (&loop2, &body);
2462 /* Build the offsets for the temporary from the loop variables. The
2463 temporary array has lbounds of zero and strides of one in all
2464 dimensions, so this is very simple. The offset is only computed
2465 outside the innermost loop, so the overall transfer could be
2466 optimized further. */
2467 info = &rse.ss->data.info;
2468 dimen = info->dimen;
2470 tmp_index = gfc_index_zero_node;
2471 for (n = dimen - 1; n > 0; n--)
2474 tmp = rse.loop->loopvar[n];
2475 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2476 tmp, rse.loop->from[n]);
2477 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2480 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2481 gfc_array_index_type,
2482 rse.loop->to[n-1], rse.loop->from[n-1]);
2483 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2484 gfc_array_index_type,
2485 tmp_str, gfc_index_one_node);
2487 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2488 gfc_array_index_type, tmp, tmp_str);
2491 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2492 gfc_array_index_type,
2493 tmp_index, rse.loop->from[0]);
2494 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2496 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2497 gfc_array_index_type,
2498 rse.loop->loopvar[0], offset);
2500 /* Now use the offset for the reference. */
2501 tmp = build_fold_indirect_ref_loc (input_location,
2503 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2505 if (expr->ts.type == BT_CHARACTER)
2506 rse.string_length = expr->ts.u.cl->backend_decl;
2508 gfc_conv_expr (&lse, expr);
2510 gcc_assert (lse.ss == gfc_ss_terminator);
2512 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2513 gfc_add_expr_to_block (&body, tmp);
2515 /* Generate the copying loops. */
2516 gfc_trans_scalarizing_loops (&loop2, &body);
2518 /* Wrap the whole thing up by adding the second loop to the post-block
2519 and following it by the post-block of the first loop. In this way,
2520 if the temporary needs freeing, it is done after use! */
2521 if (intent != INTENT_IN)
2523 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2524 gfc_add_block_to_block (&parmse->post, &loop2.post);
2527 gfc_add_block_to_block (&parmse->post, &loop.post);
2529 gfc_cleanup_loop (&loop);
2530 gfc_cleanup_loop (&loop2);
2532 /* Pass the string length to the argument expression. */
2533 if (expr->ts.type == BT_CHARACTER)
2534 parmse->string_length = expr->ts.u.cl->backend_decl;
2536 /* Determine the offset for pointer formal arguments and set the
2540 size = gfc_index_one_node;
2541 offset = gfc_index_zero_node;
2542 for (n = 0; n < dimen; n++)
2544 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2546 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2547 gfc_array_index_type, tmp,
2548 gfc_index_one_node);
2549 gfc_conv_descriptor_ubound_set (&parmse->pre,
2553 gfc_conv_descriptor_lbound_set (&parmse->pre,
2556 gfc_index_one_node);
2557 size = gfc_evaluate_now (size, &parmse->pre);
2558 offset = fold_build2_loc (input_location, MINUS_EXPR,
2559 gfc_array_index_type,
2561 offset = gfc_evaluate_now (offset, &parmse->pre);
2562 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2563 gfc_array_index_type,
2564 rse.loop->to[n], rse.loop->from[n]);
2565 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2566 gfc_array_index_type,
2567 tmp, gfc_index_one_node);
2568 size = fold_build2_loc (input_location, MULT_EXPR,
2569 gfc_array_index_type, size, tmp);
2572 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2576 /* We want either the address for the data or the address of the descriptor,
2577 depending on the mode of passing array arguments. */
2579 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2581 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2587 /* Generate the code for argument list functions. */
2590 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2592 /* Pass by value for g77 %VAL(arg), pass the address
2593 indirectly for %LOC, else by reference. Thus %REF
2594 is a "do-nothing" and %LOC is the same as an F95
2596 if (strncmp (name, "%VAL", 4) == 0)
2597 gfc_conv_expr (se, expr);
2598 else if (strncmp (name, "%LOC", 4) == 0)
2600 gfc_conv_expr_reference (se, expr);
2601 se->expr = gfc_build_addr_expr (NULL, se->expr);
2603 else if (strncmp (name, "%REF", 4) == 0)
2604 gfc_conv_expr_reference (se, expr);
2606 gfc_error ("Unknown argument list function at %L", &expr->where);
2610 /* Takes a derived type expression and returns the address of a temporary
2611 class object of the 'declared' type. */
2613 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2614 gfc_typespec class_ts)
2618 gfc_symbol *declared = class_ts.u.derived;
2624 /* The derived type needs to be converted to a temporary
2626 tmp = gfc_typenode_for_spec (&class_ts);
2627 var = gfc_create_var (tmp, "class");
2630 cmp = gfc_find_component (declared, "_vptr", true, true);
2631 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2632 TREE_TYPE (cmp->backend_decl),
2633 var, cmp->backend_decl, NULL_TREE);
2635 /* Remember the vtab corresponds to the derived type
2636 not to the class declared type. */
2637 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2639 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2640 gfc_add_modify (&parmse->pre, ctree,
2641 fold_convert (TREE_TYPE (ctree), tmp));
2643 /* Now set the data field. */
2644 cmp = gfc_find_component (declared, "_data", true, true);
2645 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2646 TREE_TYPE (cmp->backend_decl),
2647 var, cmp->backend_decl, NULL_TREE);
2648 ss = gfc_walk_expr (e);
2649 if (ss == gfc_ss_terminator)
2652 gfc_conv_expr_reference (parmse, e);
2653 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2654 gfc_add_modify (&parmse->pre, ctree, tmp);
2659 gfc_conv_expr (parmse, e);
2660 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2663 /* Pass the address of the class object. */
2664 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2668 /* The following routine generates code for the intrinsic
2669 procedures from the ISO_C_BINDING module:
2671 * C_FUNLOC (function)
2672 * C_F_POINTER (subroutine)
2673 * C_F_PROCPOINTER (subroutine)
2674 * C_ASSOCIATED (function)
2675 One exception which is not handled here is C_F_POINTER with non-scalar
2676 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2679 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2680 gfc_actual_arglist * arg)
2685 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2687 if (arg->expr->rank == 0)
2688 gfc_conv_expr_reference (se, arg->expr);
2692 /* This is really the actual arg because no formal arglist is
2693 created for C_LOC. */
2694 fsym = arg->expr->symtree->n.sym;
2696 /* We should want it to do g77 calling convention. */
2698 && !(fsym->attr.pointer || fsym->attr.allocatable)
2699 && fsym->as->type != AS_ASSUMED_SHAPE;
2700 f = f || !sym->attr.always_explicit;
2702 argss = gfc_walk_expr (arg->expr);
2703 gfc_conv_array_parameter (se, arg->expr, argss, f,
2707 /* TODO -- the following two lines shouldn't be necessary, but if
2708 they're removed, a bug is exposed later in the code path.
2709 This workaround was thus introduced, but will have to be
2710 removed; please see PR 35150 for details about the issue. */
2711 se->expr = convert (pvoid_type_node, se->expr);
2712 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2716 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2718 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2719 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2720 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2721 gfc_conv_expr_reference (se, arg->expr);
2725 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2726 && arg->next->expr->rank == 0)
2727 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2729 /* Convert c_f_pointer if fptr is a scalar
2730 and convert c_f_procpointer. */
2734 gfc_init_se (&cptrse, NULL);
2735 gfc_conv_expr (&cptrse, arg->expr);
2736 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2737 gfc_add_block_to_block (&se->post, &cptrse.post);
2739 gfc_init_se (&fptrse, NULL);
2740 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2741 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2742 fptrse.want_pointer = 1;
2744 gfc_conv_expr (&fptrse, arg->next->expr);
2745 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2746 gfc_add_block_to_block (&se->post, &fptrse.post);
2748 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2749 && arg->next->expr->symtree->n.sym->attr.dummy)
2750 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2753 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2754 TREE_TYPE (fptrse.expr),
2756 fold_convert (TREE_TYPE (fptrse.expr),
2761 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2766 /* Build the addr_expr for the first argument. The argument is
2767 already an *address* so we don't need to set want_pointer in
2769 gfc_init_se (&arg1se, NULL);
2770 gfc_conv_expr (&arg1se, arg->expr);
2771 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2772 gfc_add_block_to_block (&se->post, &arg1se.post);
2774 /* See if we were given two arguments. */
2775 if (arg->next == NULL)
2776 /* Only given one arg so generate a null and do a
2777 not-equal comparison against the first arg. */
2778 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2780 fold_convert (TREE_TYPE (arg1se.expr),
2781 null_pointer_node));
2787 /* Given two arguments so build the arg2se from second arg. */
2788 gfc_init_se (&arg2se, NULL);
2789 gfc_conv_expr (&arg2se, arg->next->expr);
2790 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2791 gfc_add_block_to_block (&se->post, &arg2se.post);
2793 /* Generate test to compare that the two args are equal. */
2794 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2795 arg1se.expr, arg2se.expr);
2796 /* Generate test to ensure that the first arg is not null. */
2797 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2799 arg1se.expr, null_pointer_node);
2801 /* Finally, the generated test must check that both arg1 is not
2802 NULL and that it is equal to the second arg. */
2803 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2805 not_null_expr, eq_expr);
2811 /* Nothing was done. */
2815 /* Generate code for a procedure call. Note can return se->post != NULL.
2816 If se->direct_byref is set then se->expr contains the return parameter.
2817 Return nonzero, if the call has alternate specifiers.
2818 'expr' is only needed for procedure pointer components. */
2821 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2822 gfc_actual_arglist * args, gfc_expr * expr,
2823 VEC(tree,gc) *append_args)
2825 gfc_interface_mapping mapping;
2826 VEC(tree,gc) *arglist;
2827 VEC(tree,gc) *retargs;
2838 VEC(tree,gc) *stringargs;
2840 gfc_formal_arglist *formal;
2841 gfc_actual_arglist *arg;
2842 int has_alternate_specifier = 0;
2843 bool need_interface_mapping;
2850 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2851 gfc_component *comp = NULL;
2861 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2862 && conv_isocbinding_procedure (se, sym, args))
2865 gfc_is_proc_ptr_comp (expr, &comp);
2869 if (!sym->attr.elemental)
2871 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2872 if (se->ss->useflags)
2874 gcc_assert ((!comp && gfc_return_by_reference (sym)
2875 && sym->result->attr.dimension)
2876 || (comp && comp->attr.dimension));
2877 gcc_assert (se->loop != NULL);
2879 /* Access the previously obtained result. */
2880 gfc_conv_tmp_array_ref (se);
2884 info = &se->ss->data.info;
2889 gfc_init_block (&post);
2890 gfc_init_interface_mapping (&mapping);
2893 formal = sym->formal;
2894 need_interface_mapping = sym->attr.dimension ||
2895 (sym->ts.type == BT_CHARACTER
2896 && sym->ts.u.cl->length
2897 && sym->ts.u.cl->length->expr_type
2902 formal = comp->formal;
2903 need_interface_mapping = comp->attr.dimension ||
2904 (comp->ts.type == BT_CHARACTER
2905 && comp->ts.u.cl->length
2906 && comp->ts.u.cl->length->expr_type
2910 /* Evaluate the arguments. */
2911 for (arg = args; arg != NULL;
2912 arg = arg->next, formal = formal ? formal->next : NULL)
2915 fsym = formal ? formal->sym : NULL;
2916 parm_kind = MISSING;
2920 if (se->ignore_optional)
2922 /* Some intrinsics have already been resolved to the correct
2926 else if (arg->label)
2928 has_alternate_specifier = 1;
2933 /* Pass a NULL pointer for an absent arg. */
2934 gfc_init_se (&parmse, NULL);
2935 parmse.expr = null_pointer_node;
2936 if (arg->missing_arg_type == BT_CHARACTER)
2937 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2940 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2942 /* Pass a NULL pointer to denote an absent arg. */
2943 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2944 gfc_init_se (&parmse, NULL);
2945 parmse.expr = null_pointer_node;
2946 if (arg->missing_arg_type == BT_CHARACTER)
2947 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2949 else if (fsym && fsym->ts.type == BT_CLASS
2950 && e->ts.type == BT_DERIVED)
2952 /* The derived type needs to be converted to a temporary
2954 gfc_init_se (&parmse, se);
2955 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2957 else if (se->ss && se->ss->useflags)
2959 /* An elemental function inside a scalarized loop. */
2960 gfc_init_se (&parmse, se);
2961 gfc_conv_expr_reference (&parmse, e);
2962 parm_kind = ELEMENTAL;
2966 /* A scalar or transformational function. */
2967 gfc_init_se (&parmse, NULL);
2968 argss = gfc_walk_expr (e);
2970 if (argss == gfc_ss_terminator)
2972 if (e->expr_type == EXPR_VARIABLE
2973 && e->symtree->n.sym->attr.cray_pointee
2974 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2976 /* The Cray pointer needs to be converted to a pointer to
2977 a type given by the expression. */
2978 gfc_conv_expr (&parmse, e);
2979 type = build_pointer_type (TREE_TYPE (parmse.expr));
2980 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2981 parmse.expr = convert (type, tmp);
2983 else if (fsym && fsym->attr.value)
2985 if (fsym->ts.type == BT_CHARACTER
2986 && fsym->ts.is_c_interop
2987 && fsym->ns->proc_name != NULL
2988 && fsym->ns->proc_name->attr.is_bind_c)
2991 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2992 if (parmse.expr == NULL)
2993 gfc_conv_expr (&parmse, e);
2996 gfc_conv_expr (&parmse, e);
2998 else if (arg->name && arg->name[0] == '%')
2999 /* Argument list functions %VAL, %LOC and %REF are signalled
3000 through arg->name. */
3001 conv_arglist_function (&parmse, arg->expr, arg->name);
3002 else if ((e->expr_type == EXPR_FUNCTION)
3003 && ((e->value.function.esym
3004 && e->value.function.esym->result->attr.pointer)
3005 || (!e->value.function.esym
3006 && e->symtree->n.sym->attr.pointer))
3007 && fsym && fsym->attr.target)
3009 gfc_conv_expr (&parmse, e);
3010 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3012 else if (e->expr_type == EXPR_FUNCTION
3013 && e->symtree->n.sym->result
3014 && e->symtree->n.sym->result != e->symtree->n.sym
3015 && e->symtree->n.sym->result->attr.proc_pointer)
3017 /* Functions returning procedure pointers. */
3018 gfc_conv_expr (&parmse, e);
3019 if (fsym && fsym->attr.proc_pointer)
3020 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3024 gfc_conv_expr_reference (&parmse, e);
3026 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3027 allocated on entry, it must be deallocated. */
3028 if (fsym && fsym->attr.allocatable
3029 && fsym->attr.intent == INTENT_OUT)
3033 gfc_init_block (&block);
3034 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3036 gfc_add_expr_to_block (&block, tmp);
3037 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3038 void_type_node, parmse.expr,
3040 gfc_add_expr_to_block (&block, tmp);
3042 if (fsym->attr.optional
3043 && e->expr_type == EXPR_VARIABLE
3044 && e->symtree->n.sym->attr.optional)
3046 tmp = fold_build3_loc (input_location, COND_EXPR,
3048 gfc_conv_expr_present (e->symtree->n.sym),
3049 gfc_finish_block (&block),
3050 build_empty_stmt (input_location));
3053 tmp = gfc_finish_block (&block);
3055 gfc_add_expr_to_block (&se->pre, tmp);
3058 if (fsym && e->expr_type != EXPR_NULL
3059 && ((fsym->attr.pointer
3060 && fsym->attr.flavor != FL_PROCEDURE)
3061 || (fsym->attr.proc_pointer
3062 && !(e->expr_type == EXPR_VARIABLE
3063 && e->symtree->n.sym->attr.dummy))
3064 || (fsym->attr.proc_pointer
3065 && e->expr_type == EXPR_VARIABLE
3066 && gfc_is_proc_ptr_comp (e, NULL))
3067 || fsym->attr.allocatable))
3069 /* Scalar pointer dummy args require an extra level of
3070 indirection. The null pointer already contains
3071 this level of indirection. */
3072 parm_kind = SCALAR_POINTER;
3073 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3079 /* If the procedure requires an explicit interface, the actual
3080 argument is passed according to the corresponding formal
3081 argument. If the corresponding formal argument is a POINTER,
3082 ALLOCATABLE or assumed shape, we do not use g77's calling
3083 convention, and pass the address of the array descriptor
3084 instead. Otherwise we use g77's calling convention. */
3087 && !(fsym->attr.pointer || fsym->attr.allocatable)
3088 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3090 f = f || !comp->attr.always_explicit;
3092 f = f || !sym->attr.always_explicit;
3094 /* If the argument is a function call that may not create
3095 a temporary for the result, we have to check that we
3096 can do it, i.e. that there is no alias between this
3097 argument and another one. */
3098 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3104 intent = fsym->attr.intent;
3106 intent = INTENT_UNKNOWN;
3108 if (gfc_check_fncall_dependency (e, intent, sym, args,
3110 parmse.force_tmp = 1;
3112 iarg = e->value.function.actual->expr;
3114 /* Temporary needed if aliasing due to host association. */
3115 if (sym->attr.contained
3117 && !sym->attr.implicit_pure
3118 && !sym->attr.use_assoc
3119 && iarg->expr_type == EXPR_VARIABLE
3120 && sym->ns == iarg->symtree->n.sym->ns)
3121 parmse.force_tmp = 1;
3123 /* Ditto within module. */
3124 if (sym->attr.use_assoc
3126 && !sym->attr.implicit_pure
3127 && iarg->expr_type == EXPR_VARIABLE
3128 && sym->module == iarg->symtree->n.sym->module)
3129 parmse.force_tmp = 1;
3132 if (e->expr_type == EXPR_VARIABLE
3133 && is_subref_array (e))
3134 /* The actual argument is a component reference to an
3135 array of derived types. In this case, the argument
3136 is converted to a temporary, which is passed and then
3137 written back after the procedure call. */
3138 gfc_conv_subref_array_arg (&parmse, e, f,
3139 fsym ? fsym->attr.intent : INTENT_INOUT,
3140 fsym && fsym->attr.pointer);
3142 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3145 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3146 allocated on entry, it must be deallocated. */
3147 if (fsym && fsym->attr.allocatable
3148 && fsym->attr.intent == INTENT_OUT)
3150 tmp = build_fold_indirect_ref_loc (input_location,
3152 tmp = gfc_trans_dealloc_allocated (tmp);
3153 if (fsym->attr.optional
3154 && e->expr_type == EXPR_VARIABLE
3155 && e->symtree->n.sym->attr.optional)
3156 tmp = fold_build3_loc (input_location, COND_EXPR,
3158 gfc_conv_expr_present (e->symtree->n.sym),
3159 tmp, build_empty_stmt (input_location));
3160 gfc_add_expr_to_block (&se->pre, tmp);
3165 /* The case with fsym->attr.optional is that of a user subroutine
3166 with an interface indicating an optional argument. When we call
3167 an intrinsic subroutine, however, fsym is NULL, but we might still
3168 have an optional argument, so we proceed to the substitution
3170 if (e && (fsym == NULL || fsym->attr.optional))
3172 /* If an optional argument is itself an optional dummy argument,
3173 check its presence and substitute a null if absent. This is
3174 only needed when passing an array to an elemental procedure
3175 as then array elements are accessed - or no NULL pointer is
3176 allowed and a "1" or "0" should be passed if not present.
3177 When passing a non-array-descriptor full array to a
3178 non-array-descriptor dummy, no check is needed. For
3179 array-descriptor actual to array-descriptor dummy, see
3180 PR 41911 for why a check has to be inserted.
3181 fsym == NULL is checked as intrinsics required the descriptor
3182 but do not always set fsym. */
3183 if (e->expr_type == EXPR_VARIABLE
3184 && e->symtree->n.sym->attr.optional
3185 && ((e->rank > 0 && sym->attr.elemental)
3186 || e->representation.length || e->ts.type == BT_CHARACTER
3190 && (fsym->as->type == AS_ASSUMED_SHAPE
3191 || fsym->as->type == AS_DEFERRED))))))
3192 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3193 e->representation.length);
3198 /* Obtain the character length of an assumed character length
3199 length procedure from the typespec. */
3200 if (fsym->ts.type == BT_CHARACTER
3201 && parmse.string_length == NULL_TREE
3202 && e->ts.type == BT_PROCEDURE
3203 && e->symtree->n.sym->ts.type == BT_CHARACTER
3204 && e->symtree->n.sym->ts.u.cl->length != NULL
3205 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3207 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3208 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3212 if (fsym && need_interface_mapping && e)
3213 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3215 gfc_add_block_to_block (&se->pre, &parmse.pre);
3216 gfc_add_block_to_block (&post, &parmse.post);
3218 /* Allocated allocatable components of derived types must be
3219 deallocated for non-variable scalars. Non-variable arrays are
3220 dealt with in trans-array.c(gfc_conv_array_parameter). */
3221 if (e && e->ts.type == BT_DERIVED
3222 && e->ts.u.derived->attr.alloc_comp
3223 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3224 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3227 tmp = build_fold_indirect_ref_loc (input_location,
3229 parm_rank = e->rank;
3237 case (SCALAR_POINTER):
3238 tmp = build_fold_indirect_ref_loc (input_location,
3243 if (e->expr_type == EXPR_OP
3244 && e->value.op.op == INTRINSIC_PARENTHESES
3245 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3248 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3249 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3250 gfc_add_expr_to_block (&se->post, local_tmp);
3253 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3255 gfc_add_expr_to_block (&se->post, tmp);
3258 /* Add argument checking of passing an unallocated/NULL actual to
3259 a nonallocatable/nonpointer dummy. */
3261 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3263 symbol_attribute attr;
3267 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3268 attr = gfc_expr_attr (e);
3270 goto end_pointer_check;
3274 /* If the actual argument is an optional pointer/allocatable and
3275 the formal argument takes an nonpointer optional value,
3276 it is invalid to pass a non-present argument on, even
3277 though there is no technical reason for this in gfortran.
3278 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3279 tree present, null_ptr, type;
3281 if (attr.allocatable
3282 && (fsym == NULL || !fsym->attr.allocatable))
3283 asprintf (&msg, "Allocatable actual argument '%s' is not "
3284 "allocated or not present", e->symtree->n.sym->name);
3285 else if (attr.pointer
3286 && (fsym == NULL || !fsym->attr.pointer))
3287 asprintf (&msg, "Pointer actual argument '%s' is not "
3288 "associated or not present",
3289 e->symtree->n.sym->name);
3290 else if (attr.proc_pointer
3291 && (fsym == NULL || !fsym->attr.proc_pointer))
3292 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3293 "associated or not present",
3294 e->symtree->n.sym->name);
3296 goto end_pointer_check;
3298 present = gfc_conv_expr_present (e->symtree->n.sym);
3299 type = TREE_TYPE (present);
3300 present = fold_build2_loc (input_location, EQ_EXPR,
3301 boolean_type_node, present,
3303 null_pointer_node));
3304 type = TREE_TYPE (parmse.expr);
3305 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3306 boolean_type_node, parmse.expr,
3308 null_pointer_node));
3309 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3310 boolean_type_node, present, null_ptr);
3314 if (attr.allocatable
3315 && (fsym == NULL || !fsym->attr.allocatable))
3316 asprintf (&msg, "Allocatable actual argument '%s' is not "
3317 "allocated", e->symtree->n.sym->name);
3318 else if (attr.pointer
3319 && (fsym == NULL || !fsym->attr.pointer))
3320 asprintf (&msg, "Pointer actual argument '%s' is not "
3321 "associated", e->symtree->n.sym->name);
3322 else if (attr.proc_pointer
3323 && (fsym == NULL || !fsym->attr.proc_pointer))
3324 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3325 "associated", e->symtree->n.sym->name);
3327 goto end_pointer_check;
3330 cond = fold_build2_loc (input_location, EQ_EXPR,
3331 boolean_type_node, parmse.expr,
3332 fold_convert (TREE_TYPE (parmse.expr),
3333 null_pointer_node));
3336 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3342 /* Deferred length dummies pass the character length by reference
3343 so that the value can be returned. */
3344 if (parmse.string_length && fsym && fsym->ts.deferred)
3346 tmp = parmse.string_length;
3347 if (TREE_CODE (tmp) != VAR_DECL)
3348 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3349 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3352 /* Character strings are passed as two parameters, a length and a
3353 pointer - except for Bind(c) which only passes the pointer. */
3354 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3355 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3357 VEC_safe_push (tree, gc, arglist, parmse.expr);
3359 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3366 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3367 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3368 else if (ts.type == BT_CHARACTER)
3370 if (ts.u.cl->length == NULL)
3372 /* Assumed character length results are not allowed by 5.1.1.5 of the
3373 standard and are trapped in resolve.c; except in the case of SPREAD
3374 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3375 we take the character length of the first argument for the result.
3376 For dummies, we have to look through the formal argument list for
3377 this function and use the character length found there.*/
3378 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3379 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3380 else if (!sym->attr.dummy)
3381 cl.backend_decl = VEC_index (tree, stringargs, 0);
3384 formal = sym->ns->proc_name->formal;
3385 for (; formal; formal = formal->next)
3386 if (strcmp (formal->sym->name, sym->name) == 0)
3387 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3394 /* Calculate the length of the returned string. */
3395 gfc_init_se (&parmse, NULL);
3396 if (need_interface_mapping)
3397 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3399 gfc_conv_expr (&parmse, ts.u.cl->length);
3400 gfc_add_block_to_block (&se->pre, &parmse.pre);
3401 gfc_add_block_to_block (&se->post, &parmse.post);
3403 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3404 tmp = fold_build2_loc (input_location, MAX_EXPR,
3405 gfc_charlen_type_node, tmp,
3406 build_int_cst (gfc_charlen_type_node, 0));
3407 cl.backend_decl = tmp;
3410 /* Set up a charlen structure for it. */
3415 len = cl.backend_decl;
3418 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3419 || (!comp && gfc_return_by_reference (sym));
3422 if (se->direct_byref)
3424 /* Sometimes, too much indirection can be applied; e.g. for
3425 function_result = array_valued_recursive_function. */
3426 if (TREE_TYPE (TREE_TYPE (se->expr))
3427 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3428 && GFC_DESCRIPTOR_TYPE_P
3429 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3430 se->expr = build_fold_indirect_ref_loc (input_location,
3433 /* If the lhs of an assignment x = f(..) is allocatable and
3434 f2003 is allowed, we must do the automatic reallocation.
3435 TODO - deal with intrinsics, without using a temporary. */
3436 if (gfc_option.flag_realloc_lhs
3437 && se->ss && se->ss->loop_chain
3438 && se->ss->loop_chain->is_alloc_lhs
3439 && !expr->value.function.isym
3440 && sym->result->as != NULL)
3442 /* Evaluate the bounds of the result, if known. */
3443 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3446 /* Perform the automatic reallocation. */
3447 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3449 gfc_add_expr_to_block (&se->pre, tmp);
3451 /* Pass the temporary as the first argument. */
3452 result = info->descriptor;
3455 result = build_fold_indirect_ref_loc (input_location,
3457 VEC_safe_push (tree, gc, retargs, se->expr);
3459 else if (comp && comp->attr.dimension)
3461 gcc_assert (se->loop && info);
3463 /* Set the type of the array. */
3464 tmp = gfc_typenode_for_spec (&comp->ts);
3465 info->dimen = se->loop->dimen;
3467 /* Evaluate the bounds of the result, if known. */
3468 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3470 /* If the lhs of an assignment x = f(..) is allocatable and
3471 f2003 is allowed, we must not generate the function call
3472 here but should just send back the results of the mapping.
3473 This is signalled by the function ss being flagged. */
3474 if (gfc_option.flag_realloc_lhs
3475 && se->ss && se->ss->is_alloc_lhs)
3477 gfc_free_interface_mapping (&mapping);
3478 return has_alternate_specifier;
3481 /* Create a temporary to store the result. In case the function
3482 returns a pointer, the temporary will be a shallow copy and
3483 mustn't be deallocated. */
3484 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3485 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3486 NULL_TREE, false, !comp->attr.pointer,
3487 callee_alloc, &se->ss->expr->where);
3489 /* Pass the temporary as the first argument. */
3490 result = info->descriptor;
3491 tmp = gfc_build_addr_expr (NULL_TREE, result);
3492 VEC_safe_push (tree, gc, retargs, tmp);
3494 else if (!comp && sym->result->attr.dimension)
3496 gcc_assert (se->loop && info);
3498 /* Set the type of the array. */
3499 tmp = gfc_typenode_for_spec (&ts);
3500 info->dimen = se->loop->dimen;
3502 /* Evaluate the bounds of the result, if known. */
3503 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3505 /* If the lhs of an assignment x = f(..) is allocatable and
3506 f2003 is allowed, we must not generate the function call
3507 here but should just send back the results of the mapping.
3508 This is signalled by the function ss being flagged. */
3509 if (gfc_option.flag_realloc_lhs
3510 && se->ss && se->ss->is_alloc_lhs)
3512 gfc_free_interface_mapping (&mapping);
3513 return has_alternate_specifier;
3516 /* Create a temporary to store the result. In case the function
3517 returns a pointer, the temporary will be a shallow copy and
3518 mustn't be deallocated. */
3519 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3520 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3521 NULL_TREE, false, !sym->attr.pointer,
3522 callee_alloc, &se->ss->expr->where);
3524 /* Pass the temporary as the first argument. */
3525 result = info->descriptor;
3526 tmp = gfc_build_addr_expr (NULL_TREE, result);
3527 VEC_safe_push (tree, gc, retargs, tmp);
3529 else if (ts.type == BT_CHARACTER)
3531 /* Pass the string length. */
3532 type = gfc_get_character_type (ts.kind, ts.u.cl);
3533 type = build_pointer_type (type);
3535 /* Return an address to a char[0:len-1]* temporary for
3536 character pointers. */
3537 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3538 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3540 var = gfc_create_var (type, "pstr");
3542 if ((!comp && sym->attr.allocatable)
3543 || (comp && comp->attr.allocatable))
3544 gfc_add_modify (&se->pre, var,
3545 fold_convert (TREE_TYPE (var),
3546 null_pointer_node));
3548 /* Provide an address expression for the function arguments. */
3549 var = gfc_build_addr_expr (NULL_TREE, var);
3552 var = gfc_conv_string_tmp (se, type, len);
3554 VEC_safe_push (tree, gc, retargs, var);
3558 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3560 type = gfc_get_complex_type (ts.kind);
3561 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3562 VEC_safe_push (tree, gc, retargs, var);
3565 if (ts.type == BT_CHARACTER && ts.deferred
3566 && (sym->attr.allocatable || sym->attr.pointer))
3569 if (TREE_CODE (tmp) != VAR_DECL)
3570 tmp = gfc_evaluate_now (len, &se->pre);
3571 len = gfc_build_addr_expr (NULL_TREE, tmp);
3574 /* Add the string length to the argument list. */
3575 if (ts.type == BT_CHARACTER)
3576 VEC_safe_push (tree, gc, retargs, len);
3578 gfc_free_interface_mapping (&mapping);
3580 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3581 arglen = (VEC_length (tree, arglist)
3582 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3583 VEC_reserve_exact (tree, gc, retargs, arglen);
3585 /* Add the return arguments. */
3586 VEC_splice (tree, retargs, arglist);
3588 /* Add the hidden string length parameters to the arguments. */
3589 VEC_splice (tree, retargs, stringargs);
3591 /* We may want to append extra arguments here. This is used e.g. for
3592 calls to libgfortran_matmul_??, which need extra information. */
3593 if (!VEC_empty (tree, append_args))
3594 VEC_splice (tree, retargs, append_args);
3597 /* Generate the actual call. */
3598 conv_function_val (se, sym, expr);
3600 /* If there are alternate return labels, function type should be
3601 integer. Can't modify the type in place though, since it can be shared
3602 with other functions. For dummy arguments, the typing is done to
3603 this result, even if it has to be repeated for each call. */
3604 if (has_alternate_specifier
3605 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3607 if (!sym->attr.dummy)
3609 TREE_TYPE (sym->backend_decl)
3610 = build_function_type (integer_type_node,
3611 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3612 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3615 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3618 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3619 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3621 /* If we have a pointer function, but we don't want a pointer, e.g.
3624 where f is pointer valued, we have to dereference the result. */
3625 if (!se->want_pointer && !byref
3626 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3627 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3628 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3630 /* f2c calling conventions require a scalar default real function to
3631 return a double precision result. Convert this back to default
3632 real. We only care about the cases that can happen in Fortran 77.
3634 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3635 && sym->ts.kind == gfc_default_real_kind
3636 && !sym->attr.always_explicit)
3637 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3639 /* A pure function may still have side-effects - it may modify its
3641 TREE_SIDE_EFFECTS (se->expr) = 1;
3643 if (!sym->attr.pure)
3644 TREE_SIDE_EFFECTS (se->expr) = 1;
3649 /* Add the function call to the pre chain. There is no expression. */
3650 gfc_add_expr_to_block (&se->pre, se->expr);
3651 se->expr = NULL_TREE;
3653 if (!se->direct_byref)
3655 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3657 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3659 /* Check the data pointer hasn't been modified. This would
3660 happen in a function returning a pointer. */
3661 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3662 tmp = fold_build2_loc (input_location, NE_EXPR,
3665 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3668 se->expr = info->descriptor;
3669 /* Bundle in the string length. */
3670 se->string_length = len;
3672 else if (ts.type == BT_CHARACTER)
3674 /* Dereference for character pointer results. */
3675 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3676 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3677 se->expr = build_fold_indirect_ref_loc (input_location, var);
3682 se->string_length = len;
3683 else if (sym->attr.allocatable || sym->attr.pointer)
3684 se->string_length = cl.backend_decl;
3688 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3689 se->expr = build_fold_indirect_ref_loc (input_location, var);
3694 /* Follow the function call with the argument post block. */
3697 gfc_add_block_to_block (&se->pre, &post);
3699 /* Transformational functions of derived types with allocatable
3700 components must have the result allocatable components copied. */
3701 arg = expr->value.function.actual;
3702 if (result && arg && expr->rank
3703 && expr->value.function.isym
3704 && expr->value.function.isym->transformational
3705 && arg->expr->ts.type == BT_DERIVED
3706 && arg->expr->ts.u.derived->attr.alloc_comp)
3709 /* Copy the allocatable components. We have to use a
3710 temporary here to prevent source allocatable components
3711 from being corrupted. */
3712 tmp2 = gfc_evaluate_now (result, &se->pre);
3713 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3714 result, tmp2, expr->rank);
3715 gfc_add_expr_to_block (&se->pre, tmp);
3716 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3718 gfc_add_expr_to_block (&se->pre, tmp);
3720 /* Finally free the temporary's data field. */
3721 tmp = gfc_conv_descriptor_data_get (tmp2);
3722 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3723 gfc_add_expr_to_block (&se->pre, tmp);
3727 gfc_add_block_to_block (&se->post, &post);
3729 return has_alternate_specifier;
3733 /* Fill a character string with spaces. */
3736 fill_with_spaces (tree start, tree type, tree size)
3738 stmtblock_t block, loop;
3739 tree i, el, exit_label, cond, tmp;
3741 /* For a simple char type, we can call memset(). */
3742 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3743 return build_call_expr_loc (input_location,
3744 built_in_decls[BUILT_IN_MEMSET], 3, start,
3745 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3746 lang_hooks.to_target_charset (' ')),
3749 /* Otherwise, we use a loop:
3750 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3754 /* Initialize variables. */
3755 gfc_init_block (&block);
3756 i = gfc_create_var (sizetype, "i");
3757 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3758 el = gfc_create_var (build_pointer_type (type), "el");
3759 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3760 exit_label = gfc_build_label_decl (NULL_TREE);
3761 TREE_USED (exit_label) = 1;
3765 gfc_init_block (&loop);
3767 /* Exit condition. */
3768 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3769 build_zero_cst (sizetype));
3770 tmp = build1_v (GOTO_EXPR, exit_label);
3771 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3772 build_empty_stmt (input_location));
3773 gfc_add_expr_to_block (&loop, tmp);
3776 gfc_add_modify (&loop,
3777 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3778 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3780 /* Increment loop variables. */
3781 gfc_add_modify (&loop, i,
3782 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3783 TYPE_SIZE_UNIT (type)));
3784 gfc_add_modify (&loop, el,
3785 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3786 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3788 /* Making the loop... actually loop! */
3789 tmp = gfc_finish_block (&loop);
3790 tmp = build1_v (LOOP_EXPR, tmp);
3791 gfc_add_expr_to_block (&block, tmp);
3793 /* The exit label. */
3794 tmp = build1_v (LABEL_EXPR, exit_label);
3795 gfc_add_expr_to_block (&block, tmp);
3798 return gfc_finish_block (&block);
3802 /* Generate code to copy a string. */
3805 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3806 int dkind, tree slength, tree src, int skind)
3808 tree tmp, dlen, slen;
3817 stmtblock_t tempblock;
3819 gcc_assert (dkind == skind);
3821 if (slength != NULL_TREE)
3823 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3824 ssc = gfc_string_to_single_character (slen, src, skind);
3828 slen = build_int_cst (size_type_node, 1);
3832 if (dlength != NULL_TREE)
3834 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3835 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3839 dlen = build_int_cst (size_type_node, 1);
3843 /* Assign directly if the types are compatible. */
3844 if (dsc != NULL_TREE && ssc != NULL_TREE
3845 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3847 gfc_add_modify (block, dsc, ssc);
3851 /* Do nothing if the destination length is zero. */
3852 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3853 build_int_cst (size_type_node, 0));
3855 /* The following code was previously in _gfortran_copy_string:
3857 // The two strings may overlap so we use memmove.
3859 copy_string (GFC_INTEGER_4 destlen, char * dest,
3860 GFC_INTEGER_4 srclen, const char * src)
3862 if (srclen >= destlen)
3864 // This will truncate if too long.
3865 memmove (dest, src, destlen);
3869 memmove (dest, src, srclen);
3871 memset (&dest[srclen], ' ', destlen - srclen);
3875 We're now doing it here for better optimization, but the logic
3878 /* For non-default character kinds, we have to multiply the string
3879 length by the base type size. */
3880 chartype = gfc_get_char_type (dkind);
3881 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3882 fold_convert (size_type_node, slen),
3883 fold_convert (size_type_node,
3884 TYPE_SIZE_UNIT (chartype)));
3885 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3886 fold_convert (size_type_node, dlen),
3887 fold_convert (size_type_node,
3888 TYPE_SIZE_UNIT (chartype)));
3890 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3891 dest = fold_convert (pvoid_type_node, dest);
3893 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3895 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3896 src = fold_convert (pvoid_type_node, src);
3898 src = gfc_build_addr_expr (pvoid_type_node, src);
3900 /* Truncate string if source is too long. */
3901 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3903 tmp2 = build_call_expr_loc (input_location,
3904 built_in_decls[BUILT_IN_MEMMOVE],
3905 3, dest, src, dlen);
3907 /* Else copy and pad with spaces. */
3908 tmp3 = build_call_expr_loc (input_location,
3909 built_in_decls[BUILT_IN_MEMMOVE],
3910 3, dest, src, slen);
3912 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3913 dest, fold_convert (sizetype, slen));
3914 tmp4 = fill_with_spaces (tmp4, chartype,
3915 fold_build2_loc (input_location, MINUS_EXPR,
3916 TREE_TYPE(dlen), dlen, slen));
3918 gfc_init_block (&tempblock);
3919 gfc_add_expr_to_block (&tempblock, tmp3);
3920 gfc_add_expr_to_block (&tempblock, tmp4);
3921 tmp3 = gfc_finish_block (&tempblock);
3923 /* The whole copy_string function is there. */
3924 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3926 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3927 build_empty_stmt (input_location));
3928 gfc_add_expr_to_block (block, tmp);
3932 /* Translate a statement function.
3933 The value of a statement function reference is obtained by evaluating the
3934 expression using the values of the actual arguments for the values of the
3935 corresponding dummy arguments. */
3938 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3942 gfc_formal_arglist *fargs;
3943 gfc_actual_arglist *args;
3946 gfc_saved_var *saved_vars;
3952 sym = expr->symtree->n.sym;
3953 args = expr->value.function.actual;
3954 gfc_init_se (&lse, NULL);
3955 gfc_init_se (&rse, NULL);
3958 for (fargs = sym->formal; fargs; fargs = fargs->next)
3960 saved_vars = XCNEWVEC (gfc_saved_var, n);
3961 temp_vars = XCNEWVEC (tree, n);
3963 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3965 /* Each dummy shall be specified, explicitly or implicitly, to be
3967 gcc_assert (fargs->sym->attr.dimension == 0);
3970 if (fsym->ts.type == BT_CHARACTER)
3972 /* Copy string arguments. */
3975 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3976 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3978 /* Create a temporary to hold the value. */
3979 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3980 fsym->ts.u.cl->backend_decl
3981 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3983 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3984 temp_vars[n] = gfc_create_var (type, fsym->name);
3986 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3988 gfc_conv_expr (&rse, args->expr);
3989 gfc_conv_string_parameter (&rse);
3990 gfc_add_block_to_block (&se->pre, &lse.pre);
3991 gfc_add_block_to_block (&se->pre, &rse.pre);
3993 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
3994 rse.string_length, rse.expr, fsym->ts.kind);
3995 gfc_add_block_to_block (&se->pre, &lse.post);
3996 gfc_add_block_to_block (&se->pre, &rse.post);
4000 /* For everything else, just evaluate the expression. */
4002 /* Create a temporary to hold the value. */
4003 type = gfc_typenode_for_spec (&fsym->ts);
4004 temp_vars[n] = gfc_create_var (type, fsym->name);
4006 gfc_conv_expr (&lse, args->expr);
4008 gfc_add_block_to_block (&se->pre, &lse.pre);
4009 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4010 gfc_add_block_to_block (&se->pre, &lse.post);
4016 /* Use the temporary variables in place of the real ones. */
4017 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4018 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4020 gfc_conv_expr (se, sym->value);
4022 if (sym->ts.type == BT_CHARACTER)
4024 gfc_conv_const_charlen (sym->ts.u.cl);
4026 /* Force the expression to the correct length. */
4027 if (!INTEGER_CST_P (se->string_length)
4028 || tree_int_cst_lt (se->string_length,
4029 sym->ts.u.cl->backend_decl))
4031 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4032 tmp = gfc_create_var (type, sym->name);
4033 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4034 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4035 sym->ts.kind, se->string_length, se->expr,
4039 se->string_length = sym->ts.u.cl->backend_decl;
4042 /* Restore the original variables. */
4043 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4044 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4049 /* Translate a function expression. */
4052 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4056 if (expr->value.function.isym)
4058 gfc_conv_intrinsic_function (se, expr);
4062 /* We distinguish statement functions from general functions to improve
4063 runtime performance. */
4064 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4066 gfc_conv_statement_function (se, expr);
4070 /* expr.value.function.esym is the resolved (specific) function symbol for
4071 most functions. However this isn't set for dummy procedures. */
4072 sym = expr->value.function.esym;
4074 sym = expr->symtree->n.sym;
4076 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4080 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4083 is_zero_initializer_p (gfc_expr * expr)
4085 if (expr->expr_type != EXPR_CONSTANT)
4088 /* We ignore constants with prescribed memory representations for now. */
4089 if (expr->representation.string)
4092 switch (expr->ts.type)
4095 return mpz_cmp_si (expr->value.integer, 0) == 0;
4098 return mpfr_zero_p (expr->value.real)
4099 && MPFR_SIGN (expr->value.real) >= 0;
4102 return expr->value.logical == 0;
4105 return mpfr_zero_p (mpc_realref (expr->value.complex))
4106 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4107 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4108 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4118 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4120 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4121 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4123 gfc_conv_tmp_array_ref (se);
4127 /* Build a static initializer. EXPR is the expression for the initial value.
4128 The other parameters describe the variable of the component being
4129 initialized. EXPR may be null. */
4132 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4133 bool array, bool pointer, bool procptr)
4137 if (!(expr || pointer || procptr))
4140 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4141 (these are the only two iso_c_binding derived types that can be
4142 used as initialization expressions). If so, we need to modify
4143 the 'expr' to be that for a (void *). */
4144 if (expr != NULL && expr->ts.type == BT_DERIVED
4145 && expr->ts.is_iso_c && expr->ts.u.derived)
4147 gfc_symbol *derived = expr->ts.u.derived;
4149 /* The derived symbol has already been converted to a (void *). Use
4151 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4152 expr->ts.f90_type = derived->ts.f90_type;
4154 gfc_init_se (&se, NULL);
4155 gfc_conv_constant (&se, expr);
4156 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4160 if (array && !procptr)
4163 /* Arrays need special handling. */
4165 ctor = gfc_build_null_descriptor (type);
4166 /* Special case assigning an array to zero. */
4167 else if (is_zero_initializer_p (expr))
4168 ctor = build_constructor (type, NULL);
4170 ctor = gfc_conv_array_initializer (type, expr);
4171 TREE_STATIC (ctor) = 1;
4174 else if (pointer || procptr)
4176 if (!expr || expr->expr_type == EXPR_NULL)
4177 return fold_convert (type, null_pointer_node);
4180 gfc_init_se (&se, NULL);
4181 se.want_pointer = 1;
4182 gfc_conv_expr (&se, expr);
4183 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4193 gfc_init_se (&se, NULL);
4194 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4195 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4197 gfc_conv_structure (&se, expr, 1);
4198 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4199 TREE_STATIC (se.expr) = 1;
4204 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4205 TREE_STATIC (ctor) = 1;
4210 gfc_init_se (&se, NULL);
4211 gfc_conv_constant (&se, expr);
4212 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4219 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4231 gfc_start_block (&block);
4233 /* Initialize the scalarizer. */
4234 gfc_init_loopinfo (&loop);
4236 gfc_init_se (&lse, NULL);
4237 gfc_init_se (&rse, NULL);
4240 rss = gfc_walk_expr (expr);
4241 if (rss == gfc_ss_terminator)
4243 /* The rhs is scalar. Add a ss for the expression. */
4244 rss = gfc_get_ss ();
4245 rss->next = gfc_ss_terminator;
4246 rss->type = GFC_SS_SCALAR;
4250 /* Create a SS for the destination. */
4251 lss = gfc_get_ss ();
4252 lss->type = GFC_SS_COMPONENT;
4254 lss->shape = gfc_get_shape (cm->as->rank);
4255 lss->next = gfc_ss_terminator;
4256 lss->data.info.dimen = cm->as->rank;
4257 lss->data.info.descriptor = dest;
4258 lss->data.info.data = gfc_conv_array_data (dest);
4259 lss->data.info.offset = gfc_conv_array_offset (dest);
4260 for (n = 0; n < cm->as->rank; n++)
4262 lss->data.info.dim[n] = n;
4263 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4264 lss->data.info.stride[n] = gfc_index_one_node;
4266 mpz_init (lss->shape[n]);
4267 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4268 cm->as->lower[n]->value.integer);
4269 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4272 /* Associate the SS with the loop. */
4273 gfc_add_ss_to_loop (&loop, lss);
4274 gfc_add_ss_to_loop (&loop, rss);
4276 /* Calculate the bounds of the scalarization. */
4277 gfc_conv_ss_startstride (&loop);
4279 /* Setup the scalarizing loops. */
4280 gfc_conv_loop_setup (&loop, &expr->where);
4282 /* Setup the gfc_se structures. */
4283 gfc_copy_loopinfo_to_se (&lse, &loop);
4284 gfc_copy_loopinfo_to_se (&rse, &loop);
4287 gfc_mark_ss_chain_used (rss, 1);
4289 gfc_mark_ss_chain_used (lss, 1);
4291 /* Start the scalarized loop body. */
4292 gfc_start_scalarized_body (&loop, &body);
4294 gfc_conv_tmp_array_ref (&lse);
4295 if (cm->ts.type == BT_CHARACTER)
4296 lse.string_length = cm->ts.u.cl->backend_decl;
4298 gfc_conv_expr (&rse, expr);
4300 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4301 gfc_add_expr_to_block (&body, tmp);
4303 gcc_assert (rse.ss == gfc_ss_terminator);
4305 /* Generate the copying loops. */
4306 gfc_trans_scalarizing_loops (&loop, &body);
4308 /* Wrap the whole thing up. */
4309 gfc_add_block_to_block (&block, &loop.pre);
4310 gfc_add_block_to_block (&block, &loop.post);
4312 for (n = 0; n < cm->as->rank; n++)
4313 mpz_clear (lss->shape[n]);
4316 gfc_cleanup_loop (&loop);
4318 return gfc_finish_block (&block);
4323 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4334 gfc_expr *arg = NULL;
4336 gfc_start_block (&block);
4337 gfc_init_se (&se, NULL);
4339 /* Get the descriptor for the expressions. */
4340 rss = gfc_walk_expr (expr);
4341 se.want_pointer = 0;
4342 gfc_conv_expr_descriptor (&se, expr, rss);
4343 gfc_add_block_to_block (&block, &se.pre);
4344 gfc_add_modify (&block, dest, se.expr);
4346 /* Deal with arrays of derived types with allocatable components. */
4347 if (cm->ts.type == BT_DERIVED
4348 && cm->ts.u.derived->attr.alloc_comp)
4349 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4353 tmp = gfc_duplicate_allocatable (dest, se.expr,
4354 TREE_TYPE(cm->backend_decl),
4357 gfc_add_expr_to_block (&block, tmp);
4358 gfc_add_block_to_block (&block, &se.post);
4360 if (expr->expr_type != EXPR_VARIABLE)
4361 gfc_conv_descriptor_data_set (&block, se.expr,
4364 /* We need to know if the argument of a conversion function is a
4365 variable, so that the correct lower bound can be used. */
4366 if (expr->expr_type == EXPR_FUNCTION
4367 && expr->value.function.isym
4368 && expr->value.function.isym->conversion
4369 && expr->value.function.actual->expr
4370 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4371 arg = expr->value.function.actual->expr;
4373 /* Obtain the array spec of full array references. */
4375 as = gfc_get_full_arrayspec_from_expr (arg);
4377 as = gfc_get_full_arrayspec_from_expr (expr);
4379 /* Shift the lbound and ubound of temporaries to being unity,
4380 rather than zero, based. Always calculate the offset. */
4381 offset = gfc_conv_descriptor_offset_get (dest);
4382 gfc_add_modify (&block, offset, gfc_index_zero_node);
4383 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4385 for (n = 0; n < expr->rank; n++)
4390 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4391 TODO It looks as if gfc_conv_expr_descriptor should return
4392 the correct bounds and that the following should not be
4393 necessary. This would simplify gfc_conv_intrinsic_bound
4395 if (as && as->lower[n])
4398 gfc_init_se (&lbse, NULL);
4399 gfc_conv_expr (&lbse, as->lower[n]);
4400 gfc_add_block_to_block (&block, &lbse.pre);
4401 lbound = gfc_evaluate_now (lbse.expr, &block);
4405 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4406 lbound = gfc_conv_descriptor_lbound_get (tmp,
4410 lbound = gfc_conv_descriptor_lbound_get (dest,
4413 lbound = gfc_index_one_node;
4415 lbound = fold_convert (gfc_array_index_type, lbound);
4417 /* Shift the bounds and set the offset accordingly. */
4418 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4419 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4420 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4421 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4423 gfc_conv_descriptor_ubound_set (&block, dest,
4424 gfc_rank_cst[n], tmp);
4425 gfc_conv_descriptor_lbound_set (&block, dest,
4426 gfc_rank_cst[n], lbound);
4428 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4429 gfc_conv_descriptor_lbound_get (dest,
4431 gfc_conv_descriptor_stride_get (dest,
4433 gfc_add_modify (&block, tmp2, tmp);
4434 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4436 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4441 /* If a conversion expression has a null data pointer
4442 argument, nullify the allocatable component. */
4446 if (arg->symtree->n.sym->attr.allocatable
4447 || arg->symtree->n.sym->attr.pointer)
4449 non_null_expr = gfc_finish_block (&block);
4450 gfc_start_block (&block);
4451 gfc_conv_descriptor_data_set (&block, dest,
4453 null_expr = gfc_finish_block (&block);
4454 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4455 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4456 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4457 return build3_v (COND_EXPR, tmp,
4458 null_expr, non_null_expr);
4462 return gfc_finish_block (&block);
4466 /* Assign a single component of a derived type constructor. */
4469 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4477 gfc_start_block (&block);
4479 if (cm->attr.pointer)
4481 gfc_init_se (&se, NULL);
4482 /* Pointer component. */
4483 if (cm->attr.dimension)
4485 /* Array pointer. */
4486 if (expr->expr_type == EXPR_NULL)
4487 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4490 rss = gfc_walk_expr (expr);
4491 se.direct_byref = 1;
4493 gfc_conv_expr_descriptor (&se, expr, rss);
4494 gfc_add_block_to_block (&block, &se.pre);
4495 gfc_add_block_to_block (&block, &se.post);
4500 /* Scalar pointers. */
4501 se.want_pointer = 1;
4502 gfc_conv_expr (&se, expr);
4503 gfc_add_block_to_block (&block, &se.pre);
4504 gfc_add_modify (&block, dest,
4505 fold_convert (TREE_TYPE (dest), se.expr));
4506 gfc_add_block_to_block (&block, &se.post);
4509 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4511 /* NULL initialization for CLASS components. */
4512 tmp = gfc_trans_structure_assign (dest,
4513 gfc_class_null_initializer (&cm->ts));
4514 gfc_add_expr_to_block (&block, tmp);
4516 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4518 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4519 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4520 else if (cm->attr.allocatable)
4522 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4523 gfc_add_expr_to_block (&block, tmp);
4527 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4528 gfc_add_expr_to_block (&block, tmp);
4531 else if (expr->ts.type == BT_DERIVED)
4533 if (expr->expr_type != EXPR_STRUCTURE)
4535 gfc_init_se (&se, NULL);
4536 gfc_conv_expr (&se, expr);
4537 gfc_add_block_to_block (&block, &se.pre);
4538 gfc_add_modify (&block, dest,
4539 fold_convert (TREE_TYPE (dest), se.expr));
4540 gfc_add_block_to_block (&block, &se.post);
4544 /* Nested constructors. */
4545 tmp = gfc_trans_structure_assign (dest, expr);
4546 gfc_add_expr_to_block (&block, tmp);
4551 /* Scalar component. */
4552 gfc_init_se (&se, NULL);
4553 gfc_init_se (&lse, NULL);
4555 gfc_conv_expr (&se, expr);
4556 if (cm->ts.type == BT_CHARACTER)
4557 lse.string_length = cm->ts.u.cl->backend_decl;
4559 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4560 gfc_add_expr_to_block (&block, tmp);
4562 return gfc_finish_block (&block);
4565 /* Assign a derived type constructor to a variable. */
4568 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4576 gfc_start_block (&block);
4577 cm = expr->ts.u.derived->components;
4579 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4580 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4581 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4585 gcc_assert (cm->backend_decl == NULL);
4586 gfc_init_se (&se, NULL);
4587 gfc_init_se (&lse, NULL);
4588 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4590 gfc_add_modify (&block, lse.expr,
4591 fold_convert (TREE_TYPE (lse.expr), se.expr));
4593 return gfc_finish_block (&block);
4596 for (c = gfc_constructor_first (expr->value.constructor);
4597 c; c = gfc_constructor_next (c), cm = cm->next)
4599 /* Skip absent members in default initializers. */
4603 field = cm->backend_decl;
4604 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4605 dest, field, NULL_TREE);
4606 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4607 gfc_add_expr_to_block (&block, tmp);
4609 return gfc_finish_block (&block);
4612 /* Build an expression for a constructor. If init is nonzero then
4613 this is part of a static variable initializer. */
4616 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4623 VEC(constructor_elt,gc) *v = NULL;
4625 gcc_assert (se->ss == NULL);
4626 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4627 type = gfc_typenode_for_spec (&expr->ts);
4631 /* Create a temporary variable and fill it in. */
4632 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4633 tmp = gfc_trans_structure_assign (se->expr, expr);
4634 gfc_add_expr_to_block (&se->pre, tmp);
4638 cm = expr->ts.u.derived->components;
4640 for (c = gfc_constructor_first (expr->value.constructor);
4641 c; c = gfc_constructor_next (c), cm = cm->next)
4643 /* Skip absent members in default initializers and allocatable
4644 components. Although the latter have a default initializer
4645 of EXPR_NULL,... by default, the static nullify is not needed
4646 since this is done every time we come into scope. */
4647 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4650 if (strcmp (cm->name, "_size") == 0)
4652 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4653 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4655 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4656 && strcmp (cm->name, "_extends") == 0)
4660 vtabs = cm->initializer->symtree->n.sym;
4661 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4662 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4666 val = gfc_conv_initializer (c->expr, &cm->ts,
4667 TREE_TYPE (cm->backend_decl),
4668 cm->attr.dimension, cm->attr.pointer,
4669 cm->attr.proc_pointer);
4671 /* Append it to the constructor list. */
4672 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4675 se->expr = build_constructor (type, v);
4677 TREE_CONSTANT (se->expr) = 1;
4681 /* Translate a substring expression. */
4684 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4690 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4692 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4693 expr->value.character.length,
4694 expr->value.character.string);
4696 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4697 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4700 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4704 /* Entry point for expression translation. Evaluates a scalar quantity.
4705 EXPR is the expression to be translated, and SE is the state structure if
4706 called from within the scalarized. */
4709 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4711 if (se->ss && se->ss->expr == expr
4712 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4714 /* Substitute a scalar expression evaluated outside the scalarization
4716 se->expr = se->ss->data.scalar.expr;
4717 if (se->ss->type == GFC_SS_REFERENCE)
4718 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4719 se->string_length = se->ss->string_length;
4720 gfc_advance_se_ss_chain (se);
4724 /* We need to convert the expressions for the iso_c_binding derived types.
4725 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4726 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4727 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4728 updated to be an integer with a kind equal to the size of a (void *). */
4729 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4730 && expr->ts.u.derived->attr.is_iso_c)
4732 if (expr->expr_type == EXPR_VARIABLE
4733 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4734 || expr->symtree->n.sym->intmod_sym_id
4735 == ISOCBINDING_NULL_FUNPTR))
4737 /* Set expr_type to EXPR_NULL, which will result in
4738 null_pointer_node being used below. */
4739 expr->expr_type = EXPR_NULL;
4743 /* Update the type/kind of the expression to be what the new
4744 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4745 expr->ts.type = expr->ts.u.derived->ts.type;
4746 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4747 expr->ts.kind = expr->ts.u.derived->ts.kind;
4751 switch (expr->expr_type)
4754 gfc_conv_expr_op (se, expr);
4758 gfc_conv_function_expr (se, expr);
4762 gfc_conv_constant (se, expr);
4766 gfc_conv_variable (se, expr);
4770 se->expr = null_pointer_node;
4773 case EXPR_SUBSTRING:
4774 gfc_conv_substring_expr (se, expr);
4777 case EXPR_STRUCTURE:
4778 gfc_conv_structure (se, expr, 0);
4782 gfc_conv_array_constructor_expr (se, expr);
4791 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4792 of an assignment. */
4794 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4796 gfc_conv_expr (se, expr);
4797 /* All numeric lvalues should have empty post chains. If not we need to
4798 figure out a way of rewriting an lvalue so that it has no post chain. */
4799 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4802 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4803 numeric expressions. Used for scalar values where inserting cleanup code
4806 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4810 gcc_assert (expr->ts.type != BT_CHARACTER);
4811 gfc_conv_expr (se, expr);
4814 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4815 gfc_add_modify (&se->pre, val, se->expr);
4817 gfc_add_block_to_block (&se->pre, &se->post);
4821 /* Helper to translate an expression and convert it to a particular type. */
4823 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4825 gfc_conv_expr_val (se, expr);
4826 se->expr = convert (type, se->expr);
4830 /* Converts an expression so that it can be passed by reference. Scalar
4834 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4838 if (se->ss && se->ss->expr == expr
4839 && se->ss->type == GFC_SS_REFERENCE)
4841 /* Returns a reference to the scalar evaluated outside the loop
4843 gfc_conv_expr (se, expr);
4847 if (expr->ts.type == BT_CHARACTER)
4849 gfc_conv_expr (se, expr);
4850 gfc_conv_string_parameter (se);
4854 if (expr->expr_type == EXPR_VARIABLE)
4856 se->want_pointer = 1;
4857 gfc_conv_expr (se, expr);
4860 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4861 gfc_add_modify (&se->pre, var, se->expr);
4862 gfc_add_block_to_block (&se->pre, &se->post);
4868 if (expr->expr_type == EXPR_FUNCTION
4869 && ((expr->value.function.esym
4870 && expr->value.function.esym->result->attr.pointer
4871 && !expr->value.function.esym->result->attr.dimension)
4872 || (!expr->value.function.esym
4873 && expr->symtree->n.sym->attr.pointer
4874 && !expr->symtree->n.sym->attr.dimension)))
4876 se->want_pointer = 1;
4877 gfc_conv_expr (se, expr);
4878 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4879 gfc_add_modify (&se->pre, var, se->expr);
4885 gfc_conv_expr (se, expr);
4887 /* Create a temporary var to hold the value. */
4888 if (TREE_CONSTANT (se->expr))
4890 tree tmp = se->expr;
4891 STRIP_TYPE_NOPS (tmp);
4892 var = build_decl (input_location,
4893 CONST_DECL, NULL, TREE_TYPE (tmp));
4894 DECL_INITIAL (var) = tmp;
4895 TREE_STATIC (var) = 1;
4900 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4901 gfc_add_modify (&se->pre, var, se->expr);
4903 gfc_add_block_to_block (&se->pre, &se->post);
4905 /* Take the address of that value. */
4906 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4911 gfc_trans_pointer_assign (gfc_code * code)
4913 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4917 /* Generate code for a pointer assignment. */
4920 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4931 gfc_start_block (&block);
4933 gfc_init_se (&lse, NULL);
4935 lss = gfc_walk_expr (expr1);
4936 rss = gfc_walk_expr (expr2);
4937 if (lss == gfc_ss_terminator)
4939 /* Scalar pointers. */
4940 lse.want_pointer = 1;
4941 gfc_conv_expr (&lse, expr1);
4942 gcc_assert (rss == gfc_ss_terminator);
4943 gfc_init_se (&rse, NULL);
4944 rse.want_pointer = 1;
4945 gfc_conv_expr (&rse, expr2);
4947 if (expr1->symtree->n.sym->attr.proc_pointer
4948 && expr1->symtree->n.sym->attr.dummy)
4949 lse.expr = build_fold_indirect_ref_loc (input_location,
4952 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4953 && expr2->symtree->n.sym->attr.dummy)
4954 rse.expr = build_fold_indirect_ref_loc (input_location,
4957 gfc_add_block_to_block (&block, &lse.pre);
4958 gfc_add_block_to_block (&block, &rse.pre);
4960 /* Check character lengths if character expression. The test is only
4961 really added if -fbounds-check is enabled. Exclude deferred
4962 character length lefthand sides. */
4963 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4964 && !(expr1->ts.deferred
4965 && (TREE_CODE (lse.string_length) == VAR_DECL))
4966 && !expr1->symtree->n.sym->attr.proc_pointer
4967 && !gfc_is_proc_ptr_comp (expr1, NULL))
4969 gcc_assert (expr2->ts.type == BT_CHARACTER);
4970 gcc_assert (lse.string_length && rse.string_length);
4971 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4972 lse.string_length, rse.string_length,
4976 /* The assignment to an deferred character length sets the string
4977 length to that of the rhs. */
4978 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4980 if (expr2->expr_type != EXPR_NULL)
4981 gfc_add_modify (&block, lse.string_length, rse.string_length);
4983 gfc_add_modify (&block, lse.string_length,
4984 build_int_cst (gfc_charlen_type_node, 0));
4987 gfc_add_modify (&block, lse.expr,
4988 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4990 gfc_add_block_to_block (&block, &rse.post);
4991 gfc_add_block_to_block (&block, &lse.post);
4998 tree strlen_rhs = NULL_TREE;
5000 /* Array pointer. Find the last reference on the LHS and if it is an
5001 array section ref, we're dealing with bounds remapping. In this case,
5002 set it to AR_FULL so that gfc_conv_expr_descriptor does
5003 not see it and process the bounds remapping afterwards explicitely. */
5004 for (remap = expr1->ref; remap; remap = remap->next)
5005 if (!remap->next && remap->type == REF_ARRAY
5006 && remap->u.ar.type == AR_SECTION)
5008 remap->u.ar.type = AR_FULL;
5011 rank_remap = (remap && remap->u.ar.end[0]);
5013 gfc_conv_expr_descriptor (&lse, expr1, lss);
5014 strlen_lhs = lse.string_length;
5017 if (expr2->expr_type == EXPR_NULL)
5019 /* Just set the data pointer to null. */
5020 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5022 else if (rank_remap)
5024 /* If we are rank-remapping, just get the RHS's descriptor and
5025 process this later on. */
5026 gfc_init_se (&rse, NULL);
5027 rse.direct_byref = 1;
5028 rse.byref_noassign = 1;
5029 gfc_conv_expr_descriptor (&rse, expr2, rss);
5030 strlen_rhs = rse.string_length;
5032 else if (expr2->expr_type == EXPR_VARIABLE)
5034 /* Assign directly to the LHS's descriptor. */
5035 lse.direct_byref = 1;
5036 gfc_conv_expr_descriptor (&lse, expr2, rss);
5037 strlen_rhs = lse.string_length;
5039 /* If this is a subreference array pointer assignment, use the rhs
5040 descriptor element size for the lhs span. */
5041 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5043 decl = expr1->symtree->n.sym->backend_decl;
5044 gfc_init_se (&rse, NULL);
5045 rse.descriptor_only = 1;
5046 gfc_conv_expr (&rse, expr2);
5047 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5048 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5049 if (!INTEGER_CST_P (tmp))
5050 gfc_add_block_to_block (&lse.post, &rse.pre);
5051 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5056 /* Assign to a temporary descriptor and then copy that
5057 temporary to the pointer. */
5058 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5061 lse.direct_byref = 1;
5062 gfc_conv_expr_descriptor (&lse, expr2, rss);
5063 strlen_rhs = lse.string_length;
5064 gfc_add_modify (&lse.pre, desc, tmp);
5067 gfc_add_block_to_block (&block, &lse.pre);
5069 gfc_add_block_to_block (&block, &rse.pre);
5071 /* If we do bounds remapping, update LHS descriptor accordingly. */
5075 gcc_assert (remap->u.ar.dimen == expr1->rank);
5079 /* Do rank remapping. We already have the RHS's descriptor
5080 converted in rse and now have to build the correct LHS
5081 descriptor for it. */
5085 tree lbound, ubound;
5088 dtype = gfc_conv_descriptor_dtype (desc);
5089 tmp = gfc_get_dtype (TREE_TYPE (desc));
5090 gfc_add_modify (&block, dtype, tmp);
5092 /* Copy data pointer. */
5093 data = gfc_conv_descriptor_data_get (rse.expr);
5094 gfc_conv_descriptor_data_set (&block, desc, data);
5096 /* Copy offset but adjust it such that it would correspond
5097 to a lbound of zero. */
5098 offs = gfc_conv_descriptor_offset_get (rse.expr);
5099 for (dim = 0; dim < expr2->rank; ++dim)
5101 stride = gfc_conv_descriptor_stride_get (rse.expr,
5103 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5105 tmp = fold_build2_loc (input_location, MULT_EXPR,
5106 gfc_array_index_type, stride, lbound);
5107 offs = fold_build2_loc (input_location, PLUS_EXPR,
5108 gfc_array_index_type, offs, tmp);
5110 gfc_conv_descriptor_offset_set (&block, desc, offs);
5112 /* Set the bounds as declared for the LHS and calculate strides as
5113 well as another offset update accordingly. */
5114 stride = gfc_conv_descriptor_stride_get (rse.expr,
5116 for (dim = 0; dim < expr1->rank; ++dim)
5121 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5123 /* Convert declared bounds. */
5124 gfc_init_se (&lower_se, NULL);
5125 gfc_init_se (&upper_se, NULL);
5126 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5127 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5129 gfc_add_block_to_block (&block, &lower_se.pre);
5130 gfc_add_block_to_block (&block, &upper_se.pre);
5132 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5133 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5135 lbound = gfc_evaluate_now (lbound, &block);
5136 ubound = gfc_evaluate_now (ubound, &block);
5138 gfc_add_block_to_block (&block, &lower_se.post);
5139 gfc_add_block_to_block (&block, &upper_se.post);
5141 /* Set bounds in descriptor. */
5142 gfc_conv_descriptor_lbound_set (&block, desc,
5143 gfc_rank_cst[dim], lbound);
5144 gfc_conv_descriptor_ubound_set (&block, desc,
5145 gfc_rank_cst[dim], ubound);
5148 stride = gfc_evaluate_now (stride, &block);
5149 gfc_conv_descriptor_stride_set (&block, desc,
5150 gfc_rank_cst[dim], stride);
5152 /* Update offset. */
5153 offs = gfc_conv_descriptor_offset_get (desc);
5154 tmp = fold_build2_loc (input_location, MULT_EXPR,
5155 gfc_array_index_type, lbound, stride);
5156 offs = fold_build2_loc (input_location, MINUS_EXPR,
5157 gfc_array_index_type, offs, tmp);
5158 offs = gfc_evaluate_now (offs, &block);
5159 gfc_conv_descriptor_offset_set (&block, desc, offs);
5161 /* Update stride. */
5162 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5163 stride = fold_build2_loc (input_location, MULT_EXPR,
5164 gfc_array_index_type, stride, tmp);
5169 /* Bounds remapping. Just shift the lower bounds. */
5171 gcc_assert (expr1->rank == expr2->rank);
5173 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5177 gcc_assert (remap->u.ar.start[dim]);
5178 gcc_assert (!remap->u.ar.end[dim]);
5179 gfc_init_se (&lbound_se, NULL);
5180 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5182 gfc_add_block_to_block (&block, &lbound_se.pre);
5183 gfc_conv_shift_descriptor_lbound (&block, desc,
5184 dim, lbound_se.expr);
5185 gfc_add_block_to_block (&block, &lbound_se.post);
5190 /* Check string lengths if applicable. The check is only really added
5191 to the output code if -fbounds-check is enabled. */
5192 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5194 gcc_assert (expr2->ts.type == BT_CHARACTER);
5195 gcc_assert (strlen_lhs && strlen_rhs);
5196 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5197 strlen_lhs, strlen_rhs, &block);
5200 /* If rank remapping was done, check with -fcheck=bounds that
5201 the target is at least as large as the pointer. */
5202 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5208 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5209 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5211 lsize = gfc_evaluate_now (lsize, &block);
5212 rsize = gfc_evaluate_now (rsize, &block);
5213 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5216 msg = _("Target of rank remapping is too small (%ld < %ld)");
5217 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5221 gfc_add_block_to_block (&block, &lse.post);
5223 gfc_add_block_to_block (&block, &rse.post);
5226 return gfc_finish_block (&block);
5230 /* Makes sure se is suitable for passing as a function string parameter. */
5231 /* TODO: Need to check all callers of this function. It may be abused. */
5234 gfc_conv_string_parameter (gfc_se * se)
5238 if (TREE_CODE (se->expr) == STRING_CST)
5240 type = TREE_TYPE (TREE_TYPE (se->expr));
5241 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5245 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5247 if (TREE_CODE (se->expr) != INDIRECT_REF)
5249 type = TREE_TYPE (se->expr);
5250 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5254 type = gfc_get_character_type_len (gfc_default_character_kind,
5256 type = build_pointer_type (type);
5257 se->expr = gfc_build_addr_expr (type, se->expr);
5261 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5265 /* Generate code for assignment of scalar variables. Includes character
5266 strings and derived types with allocatable components.
5267 If you know that the LHS has no allocations, set dealloc to false. */
5270 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5271 bool l_is_temp, bool r_is_var, bool dealloc)
5277 gfc_init_block (&block);
5279 if (ts.type == BT_CHARACTER)
5284 if (lse->string_length != NULL_TREE)
5286 gfc_conv_string_parameter (lse);
5287 gfc_add_block_to_block (&block, &lse->pre);
5288 llen = lse->string_length;
5291 if (rse->string_length != NULL_TREE)
5293 gcc_assert (rse->string_length != NULL_TREE);
5294 gfc_conv_string_parameter (rse);
5295 gfc_add_block_to_block (&block, &rse->pre);
5296 rlen = rse->string_length;
5299 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5300 rse->expr, ts.kind);
5302 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5306 /* Are the rhs and the lhs the same? */
5309 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5310 gfc_build_addr_expr (NULL_TREE, lse->expr),
5311 gfc_build_addr_expr (NULL_TREE, rse->expr));
5312 cond = gfc_evaluate_now (cond, &lse->pre);
5315 /* Deallocate the lhs allocated components as long as it is not
5316 the same as the rhs. This must be done following the assignment
5317 to prevent deallocating data that could be used in the rhs
5319 if (!l_is_temp && dealloc)
5321 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5322 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5324 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5326 gfc_add_expr_to_block (&lse->post, tmp);
5329 gfc_add_block_to_block (&block, &rse->pre);
5330 gfc_add_block_to_block (&block, &lse->pre);
5332 gfc_add_modify (&block, lse->expr,
5333 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5335 /* Do a deep copy if the rhs is a variable, if it is not the
5339 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5340 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5342 gfc_add_expr_to_block (&block, tmp);
5345 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5347 gfc_add_block_to_block (&block, &lse->pre);
5348 gfc_add_block_to_block (&block, &rse->pre);
5349 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5350 TREE_TYPE (lse->expr), rse->expr);
5351 gfc_add_modify (&block, lse->expr, tmp);
5355 gfc_add_block_to_block (&block, &lse->pre);
5356 gfc_add_block_to_block (&block, &rse->pre);
5358 gfc_add_modify (&block, lse->expr,
5359 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5362 gfc_add_block_to_block (&block, &lse->post);
5363 gfc_add_block_to_block (&block, &rse->post);
5365 return gfc_finish_block (&block);
5369 /* There are quite a lot of restrictions on the optimisation in using an
5370 array function assign without a temporary. */
5373 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5376 bool seen_array_ref;
5378 gfc_symbol *sym = expr1->symtree->n.sym;
5380 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5381 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5384 /* Elemental functions are scalarized so that they don't need a
5385 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5386 they would need special treatment in gfc_trans_arrayfunc_assign. */
5387 if (expr2->value.function.esym != NULL
5388 && expr2->value.function.esym->attr.elemental)
5391 /* Need a temporary if rhs is not FULL or a contiguous section. */
5392 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5395 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5396 if (gfc_ref_needs_temporary_p (expr1->ref))
5399 /* Functions returning pointers or allocatables need temporaries. */
5400 c = expr2->value.function.esym
5401 ? (expr2->value.function.esym->attr.pointer
5402 || expr2->value.function.esym->attr.allocatable)
5403 : (expr2->symtree->n.sym->attr.pointer
5404 || expr2->symtree->n.sym->attr.allocatable);
5408 /* Character array functions need temporaries unless the
5409 character lengths are the same. */
5410 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5412 if (expr1->ts.u.cl->length == NULL
5413 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5416 if (expr2->ts.u.cl->length == NULL
5417 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5420 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5421 expr2->ts.u.cl->length->value.integer) != 0)
5425 /* Check that no LHS component references appear during an array
5426 reference. This is needed because we do not have the means to
5427 span any arbitrary stride with an array descriptor. This check
5428 is not needed for the rhs because the function result has to be
5430 seen_array_ref = false;
5431 for (ref = expr1->ref; ref; ref = ref->next)
5433 if (ref->type == REF_ARRAY)
5434 seen_array_ref= true;
5435 else if (ref->type == REF_COMPONENT && seen_array_ref)
5439 /* Check for a dependency. */
5440 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5441 expr2->value.function.esym,
5442 expr2->value.function.actual,
5446 /* If we have reached here with an intrinsic function, we do not
5447 need a temporary except in the particular case that reallocation
5448 on assignment is active and the lhs is allocatable and a target. */
5449 if (expr2->value.function.isym)
5450 return (gfc_option.flag_realloc_lhs
5451 && sym->attr.allocatable
5452 && sym->attr.target);
5454 /* If the LHS is a dummy, we need a temporary if it is not
5456 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5459 /* If the lhs has been host_associated, is in common, a pointer or is
5460 a target and the function is not using a RESULT variable, aliasing
5461 can occur and a temporary is needed. */
5462 if ((sym->attr.host_assoc
5463 || sym->attr.in_common
5464 || sym->attr.pointer
5465 || sym->attr.cray_pointee
5466 || sym->attr.target)
5467 && expr2->symtree != NULL
5468 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5471 /* A PURE function can unconditionally be called without a temporary. */
5472 if (expr2->value.function.esym != NULL
5473 && expr2->value.function.esym->attr.pure)
5476 /* Implicit_pure functions are those which could legally be declared
5478 if (expr2->value.function.esym != NULL
5479 && expr2->value.function.esym->attr.implicit_pure)
5482 if (!sym->attr.use_assoc
5483 && !sym->attr.in_common
5484 && !sym->attr.pointer
5485 && !sym->attr.target
5486 && !sym->attr.cray_pointee
5487 && expr2->value.function.esym)
5489 /* A temporary is not needed if the function is not contained and
5490 the variable is local or host associated and not a pointer or
5492 if (!expr2->value.function.esym->attr.contained)
5495 /* A temporary is not needed if the lhs has never been host
5496 associated and the procedure is contained. */
5497 else if (!sym->attr.host_assoc)
5500 /* A temporary is not needed if the variable is local and not
5501 a pointer, a target or a result. */
5503 && expr2->value.function.esym->ns == sym->ns->parent)
5507 /* Default to temporary use. */
5512 /* Provide the loop info so that the lhs descriptor can be built for
5513 reallocatable assignments from extrinsic function calls. */
5516 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5519 /* Signal that the function call should not be made by
5520 gfc_conv_loop_setup. */
5521 se->ss->is_alloc_lhs = 1;
5522 gfc_init_loopinfo (loop);
5523 gfc_add_ss_to_loop (loop, *ss);
5524 gfc_add_ss_to_loop (loop, se->ss);
5525 gfc_conv_ss_startstride (loop);
5526 gfc_conv_loop_setup (loop, where);
5527 gfc_copy_loopinfo_to_se (se, loop);
5528 gfc_add_block_to_block (&se->pre, &loop->pre);
5529 gfc_add_block_to_block (&se->pre, &loop->post);
5530 se->ss->is_alloc_lhs = 0;
5534 /* For Assignment to a reallocatable lhs from intrinsic functions,
5535 replace the se.expr (ie. the result) with a temporary descriptor.
5536 Null the data field so that the library allocates space for the
5537 result. Free the data of the original descriptor after the function,
5538 in case it appears in an argument expression and transfer the
5539 result to the original descriptor. */
5542 fcncall_realloc_result (gfc_se *se, int rank)
5550 /* Use the allocation done by the library. Substitute the lhs
5551 descriptor with a copy, whose data field is nulled.*/
5552 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5553 /* Unallocated, the descriptor does not have a dtype. */
5554 tmp = gfc_conv_descriptor_dtype (desc);
5555 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5556 res_desc = gfc_evaluate_now (desc, &se->pre);
5557 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5558 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5560 /* Free the lhs after the function call and copy the result to
5561 the lhs descriptor. */
5562 tmp = gfc_conv_descriptor_data_get (desc);
5563 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5564 gfc_add_expr_to_block (&se->post, tmp);
5565 gfc_add_modify (&se->post, desc, res_desc);
5567 offset = gfc_index_zero_node;
5568 tmp = gfc_index_one_node;
5569 /* Now reset the bounds from zero based to unity based. */
5570 for (n = 0 ; n < rank; n++)
5572 /* Accumulate the offset. */
5573 offset = fold_build2_loc (input_location, MINUS_EXPR,
5574 gfc_array_index_type,
5576 /* Now do the bounds. */
5577 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5578 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5579 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5580 gfc_array_index_type,
5581 tmp, gfc_index_one_node);
5582 gfc_conv_descriptor_lbound_set (&se->post, desc,
5584 gfc_index_one_node);
5585 gfc_conv_descriptor_ubound_set (&se->post, desc,
5586 gfc_rank_cst[n], tmp);
5588 /* The extent for the next contribution to offset. */
5589 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5590 gfc_array_index_type,
5591 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5592 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5593 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5594 gfc_array_index_type,
5595 tmp, gfc_index_one_node);
5597 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5602 /* Try to translate array(:) = func (...), where func is a transformational
5603 array function, without using a temporary. Returns NULL if this isn't the
5607 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5611 gfc_component *comp = NULL;
5614 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5617 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5619 gcc_assert (expr2->value.function.isym
5620 || (gfc_is_proc_ptr_comp (expr2, &comp)
5621 && comp && comp->attr.dimension)
5622 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5623 && expr2->value.function.esym->result->attr.dimension));
5625 ss = gfc_walk_expr (expr1);
5626 gcc_assert (ss != gfc_ss_terminator);
5627 gfc_init_se (&se, NULL);
5628 gfc_start_block (&se.pre);
5629 se.want_pointer = 1;
5631 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5633 if (expr1->ts.type == BT_DERIVED
5634 && expr1->ts.u.derived->attr.alloc_comp)
5637 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5639 gfc_add_expr_to_block (&se.pre, tmp);
5642 se.direct_byref = 1;
5643 se.ss = gfc_walk_expr (expr2);
5644 gcc_assert (se.ss != gfc_ss_terminator);
5646 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5647 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5648 Clearly, this cannot be done for an allocatable function result, since
5649 the shape of the result is unknown and, in any case, the function must
5650 correctly take care of the reallocation internally. For intrinsic
5651 calls, the array data is freed and the library takes care of allocation.
5652 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5654 if (gfc_option.flag_realloc_lhs
5655 && gfc_is_reallocatable_lhs (expr1)
5656 && !gfc_expr_attr (expr1).codimension
5657 && !gfc_is_coindexed (expr1)
5658 && !(expr2->value.function.esym
5659 && expr2->value.function.esym->result->attr.allocatable))
5661 if (!expr2->value.function.isym)
5663 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5664 ss->is_alloc_lhs = 1;
5667 fcncall_realloc_result (&se, expr1->rank);
5670 gfc_conv_function_expr (&se, expr2);
5671 gfc_add_block_to_block (&se.pre, &se.post);
5673 return gfc_finish_block (&se.pre);
5677 /* Try to efficiently translate array(:) = 0. Return NULL if this
5681 gfc_trans_zero_assign (gfc_expr * expr)
5683 tree dest, len, type;
5687 sym = expr->symtree->n.sym;
5688 dest = gfc_get_symbol_decl (sym);
5690 type = TREE_TYPE (dest);
5691 if (POINTER_TYPE_P (type))
5692 type = TREE_TYPE (type);
5693 if (!GFC_ARRAY_TYPE_P (type))
5696 /* Determine the length of the array. */
5697 len = GFC_TYPE_ARRAY_SIZE (type);
5698 if (!len || TREE_CODE (len) != INTEGER_CST)
5701 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5702 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5703 fold_convert (gfc_array_index_type, tmp));
5705 /* If we are zeroing a local array avoid taking its address by emitting
5707 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5708 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5709 dest, build_constructor (TREE_TYPE (dest), NULL));
5711 /* Convert arguments to the correct types. */
5712 dest = fold_convert (pvoid_type_node, dest);
5713 len = fold_convert (size_type_node, len);
5715 /* Construct call to __builtin_memset. */
5716 tmp = build_call_expr_loc (input_location,
5717 built_in_decls[BUILT_IN_MEMSET],
5718 3, dest, integer_zero_node, len);
5719 return fold_convert (void_type_node, tmp);
5723 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5724 that constructs the call to __builtin_memcpy. */
5727 gfc_build_memcpy_call (tree dst, tree src, tree len)
5731 /* Convert arguments to the correct types. */
5732 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5733 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5735 dst = fold_convert (pvoid_type_node, dst);
5737 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5738 src = gfc_build_addr_expr (pvoid_type_node, src);
5740 src = fold_convert (pvoid_type_node, src);
5742 len = fold_convert (size_type_node, len);
5744 /* Construct call to __builtin_memcpy. */
5745 tmp = build_call_expr_loc (input_location,
5746 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5747 return fold_convert (void_type_node, tmp);
5751 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5752 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5753 source/rhs, both are gfc_full_array_ref_p which have been checked for
5757 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5759 tree dst, dlen, dtype;
5760 tree src, slen, stype;
5763 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5764 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5766 dtype = TREE_TYPE (dst);
5767 if (POINTER_TYPE_P (dtype))
5768 dtype = TREE_TYPE (dtype);
5769 stype = TREE_TYPE (src);
5770 if (POINTER_TYPE_P (stype))
5771 stype = TREE_TYPE (stype);
5773 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5776 /* Determine the lengths of the arrays. */
5777 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5778 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5780 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5781 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5782 dlen, fold_convert (gfc_array_index_type, tmp));
5784 slen = GFC_TYPE_ARRAY_SIZE (stype);
5785 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5787 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5788 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5789 slen, fold_convert (gfc_array_index_type, tmp));
5791 /* Sanity check that they are the same. This should always be
5792 the case, as we should already have checked for conformance. */
5793 if (!tree_int_cst_equal (slen, dlen))
5796 return gfc_build_memcpy_call (dst, src, dlen);
5800 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5801 this can't be done. EXPR1 is the destination/lhs for which
5802 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5805 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5807 unsigned HOST_WIDE_INT nelem;
5813 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5817 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5818 dtype = TREE_TYPE (dst);
5819 if (POINTER_TYPE_P (dtype))
5820 dtype = TREE_TYPE (dtype);
5821 if (!GFC_ARRAY_TYPE_P (dtype))
5824 /* Determine the lengths of the array. */
5825 len = GFC_TYPE_ARRAY_SIZE (dtype);
5826 if (!len || TREE_CODE (len) != INTEGER_CST)
5829 /* Confirm that the constructor is the same size. */
5830 if (compare_tree_int (len, nelem) != 0)
5833 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5834 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5835 fold_convert (gfc_array_index_type, tmp));
5837 stype = gfc_typenode_for_spec (&expr2->ts);
5838 src = gfc_build_constant_array_constructor (expr2, stype);
5840 stype = TREE_TYPE (src);
5841 if (POINTER_TYPE_P (stype))
5842 stype = TREE_TYPE (stype);
5844 return gfc_build_memcpy_call (dst, src, len);
5848 /* Tells whether the expression is to be treated as a variable reference. */
5851 expr_is_variable (gfc_expr *expr)
5855 if (expr->expr_type == EXPR_VARIABLE)
5858 arg = gfc_get_noncopying_intrinsic_argument (expr);
5861 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5862 return expr_is_variable (arg);
5869 /* Is the lhs OK for automatic reallocation? */
5872 is_scalar_reallocatable_lhs (gfc_expr *expr)
5876 /* An allocatable variable with no reference. */
5877 if (expr->symtree->n.sym->attr.allocatable
5881 /* All that can be left are allocatable components. */
5882 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5883 && expr->symtree->n.sym->ts.type != BT_CLASS)
5884 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5887 /* Find an allocatable component ref last. */
5888 for (ref = expr->ref; ref; ref = ref->next)
5889 if (ref->type == REF_COMPONENT
5891 && ref->u.c.component->attr.allocatable)
5898 /* Allocate or reallocate scalar lhs, as necessary. */
5901 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5915 if (!expr1 || expr1->rank)
5918 if (!expr2 || expr2->rank)
5921 /* Since this is a scalar lhs, we can afford to do this. That is,
5922 there is no risk of side effects being repeated. */
5923 gfc_init_se (&lse, NULL);
5924 lse.want_pointer = 1;
5925 gfc_conv_expr (&lse, expr1);
5927 jump_label1 = gfc_build_label_decl (NULL_TREE);
5928 jump_label2 = gfc_build_label_decl (NULL_TREE);
5930 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5931 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5932 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5934 tmp = build3_v (COND_EXPR, cond,
5935 build1_v (GOTO_EXPR, jump_label1),
5936 build_empty_stmt (input_location));
5937 gfc_add_expr_to_block (block, tmp);
5939 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5941 /* Use the rhs string length and the lhs element size. */
5942 size = string_length;
5943 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5944 tmp = TYPE_SIZE_UNIT (tmp);
5945 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5946 TREE_TYPE (tmp), tmp,
5947 fold_convert (TREE_TYPE (tmp), size));
5951 /* Otherwise use the length in bytes of the rhs. */
5952 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5953 size_in_bytes = size;
5956 tmp = build_call_expr_loc (input_location,
5957 built_in_decls[BUILT_IN_MALLOC], 1,
5959 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5960 gfc_add_modify (block, lse.expr, tmp);
5961 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5963 /* Deferred characters need checking for lhs and rhs string
5964 length. Other deferred parameter variables will have to
5966 tmp = build1_v (GOTO_EXPR, jump_label2);
5967 gfc_add_expr_to_block (block, tmp);
5969 tmp = build1_v (LABEL_EXPR, jump_label1);
5970 gfc_add_expr_to_block (block, tmp);
5972 /* For a deferred length character, reallocate if lengths of lhs and
5973 rhs are different. */
5974 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5976 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5977 expr1->ts.u.cl->backend_decl, size);
5978 /* Jump past the realloc if the lengths are the same. */
5979 tmp = build3_v (COND_EXPR, cond,
5980 build1_v (GOTO_EXPR, jump_label2),
5981 build_empty_stmt (input_location));
5982 gfc_add_expr_to_block (block, tmp);
5983 tmp = build_call_expr_loc (input_location,
5984 built_in_decls[BUILT_IN_REALLOC], 2,
5985 fold_convert (pvoid_type_node, lse.expr),
5987 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5988 gfc_add_modify (block, lse.expr, tmp);
5989 tmp = build1_v (LABEL_EXPR, jump_label2);
5990 gfc_add_expr_to_block (block, tmp);
5992 /* Update the lhs character length. */
5993 size = string_length;
5994 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
5999 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6000 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6001 init_flag indicates initialization expressions and dealloc that no
6002 deallocate prior assignment is needed (if in doubt, set true). */
6005 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6011 gfc_ss *lss_section;
6018 bool scalar_to_array;
6023 /* Assignment of the form lhs = rhs. */
6024 gfc_start_block (&block);
6026 gfc_init_se (&lse, NULL);
6027 gfc_init_se (&rse, NULL);
6030 lss = gfc_walk_expr (expr1);
6031 if (gfc_is_reallocatable_lhs (expr1)
6032 && !(expr2->expr_type == EXPR_FUNCTION
6033 && expr2->value.function.isym != NULL))
6034 lss->is_alloc_lhs = 1;
6036 if (lss != gfc_ss_terminator)
6038 /* Allow the scalarizer to workshare array assignments. */
6039 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6040 ompws_flags |= OMPWS_SCALARIZER_WS;
6042 /* The assignment needs scalarization. */
6045 /* Find a non-scalar SS from the lhs. */
6046 while (lss_section != gfc_ss_terminator
6047 && lss_section->type != GFC_SS_SECTION)
6048 lss_section = lss_section->next;
6050 gcc_assert (lss_section != gfc_ss_terminator);
6052 /* Initialize the scalarizer. */
6053 gfc_init_loopinfo (&loop);
6056 rss = gfc_walk_expr (expr2);
6057 if (rss == gfc_ss_terminator)
6059 /* The rhs is scalar. Add a ss for the expression. */
6060 rss = gfc_get_ss ();
6061 rss->next = gfc_ss_terminator;
6062 rss->type = GFC_SS_SCALAR;
6065 /* Associate the SS with the loop. */
6066 gfc_add_ss_to_loop (&loop, lss);
6067 gfc_add_ss_to_loop (&loop, rss);
6069 /* Calculate the bounds of the scalarization. */
6070 gfc_conv_ss_startstride (&loop);
6071 /* Enable loop reversal. */
6072 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6073 loop.reverse[n] = GFC_ENABLE_REVERSE;
6074 /* Resolve any data dependencies in the statement. */
6075 gfc_conv_resolve_dependencies (&loop, lss, rss);
6076 /* Setup the scalarizing loops. */
6077 gfc_conv_loop_setup (&loop, &expr2->where);
6079 /* Setup the gfc_se structures. */
6080 gfc_copy_loopinfo_to_se (&lse, &loop);
6081 gfc_copy_loopinfo_to_se (&rse, &loop);
6084 gfc_mark_ss_chain_used (rss, 1);
6085 if (loop.temp_ss == NULL)
6088 gfc_mark_ss_chain_used (lss, 1);
6092 lse.ss = loop.temp_ss;
6093 gfc_mark_ss_chain_used (lss, 3);
6094 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6097 /* Start the scalarized loop body. */
6098 gfc_start_scalarized_body (&loop, &body);
6101 gfc_init_block (&body);
6103 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6105 /* Translate the expression. */
6106 gfc_conv_expr (&rse, expr2);
6108 /* Stabilize a string length for temporaries. */
6109 if (expr2->ts.type == BT_CHARACTER)
6110 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6112 string_length = NULL_TREE;
6116 gfc_conv_tmp_array_ref (&lse);
6117 if (expr2->ts.type == BT_CHARACTER)
6118 lse.string_length = string_length;
6121 gfc_conv_expr (&lse, expr1);
6123 /* Assignments of scalar derived types with allocatable components
6124 to arrays must be done with a deep copy and the rhs temporary
6125 must have its components deallocated afterwards. */
6126 scalar_to_array = (expr2->ts.type == BT_DERIVED
6127 && expr2->ts.u.derived->attr.alloc_comp
6128 && !expr_is_variable (expr2)
6129 && !gfc_is_constant_expr (expr2)
6130 && expr1->rank && !expr2->rank);
6131 if (scalar_to_array && dealloc)
6133 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6134 gfc_add_expr_to_block (&loop.post, tmp);
6137 /* For a deferred character length function, the function call must
6138 happen before the (re)allocation of the lhs, otherwise the character
6139 length of the result is not known. */
6140 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6141 || (expr2->expr_type == EXPR_COMPCALL)
6142 || (expr2->expr_type == EXPR_PPC))
6143 && expr2->ts.deferred);
6144 if (gfc_option.flag_realloc_lhs
6145 && expr2->ts.type == BT_CHARACTER
6146 && (def_clen_func || expr2->expr_type == EXPR_OP)
6147 && expr1->ts.deferred)
6148 gfc_add_block_to_block (&block, &rse.pre);
6150 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6151 l_is_temp || init_flag,
6152 expr_is_variable (expr2) || scalar_to_array,
6154 gfc_add_expr_to_block (&body, tmp);
6156 if (lss == gfc_ss_terminator)
6158 /* F2003: Add the code for reallocation on assignment. */
6159 if (gfc_option.flag_realloc_lhs
6160 && is_scalar_reallocatable_lhs (expr1))
6161 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6164 /* Use the scalar assignment as is. */
6165 gfc_add_block_to_block (&block, &body);
6169 gcc_assert (lse.ss == gfc_ss_terminator
6170 && rse.ss == gfc_ss_terminator);
6174 gfc_trans_scalarized_loop_boundary (&loop, &body);
6176 /* We need to copy the temporary to the actual lhs. */
6177 gfc_init_se (&lse, NULL);
6178 gfc_init_se (&rse, NULL);
6179 gfc_copy_loopinfo_to_se (&lse, &loop);
6180 gfc_copy_loopinfo_to_se (&rse, &loop);
6182 rse.ss = loop.temp_ss;
6185 gfc_conv_tmp_array_ref (&rse);
6186 gfc_conv_expr (&lse, expr1);
6188 gcc_assert (lse.ss == gfc_ss_terminator
6189 && rse.ss == gfc_ss_terminator);
6191 if (expr2->ts.type == BT_CHARACTER)
6192 rse.string_length = string_length;
6194 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6195 false, false, dealloc);
6196 gfc_add_expr_to_block (&body, tmp);
6199 /* F2003: Allocate or reallocate lhs of allocatable array. */
6200 if (gfc_option.flag_realloc_lhs
6201 && gfc_is_reallocatable_lhs (expr1)
6202 && !gfc_expr_attr (expr1).codimension
6203 && !gfc_is_coindexed (expr1))
6205 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6206 if (tmp != NULL_TREE)
6207 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6210 /* Generate the copying loops. */
6211 gfc_trans_scalarizing_loops (&loop, &body);
6213 /* Wrap the whole thing up. */
6214 gfc_add_block_to_block (&block, &loop.pre);
6215 gfc_add_block_to_block (&block, &loop.post);
6217 gfc_cleanup_loop (&loop);
6220 return gfc_finish_block (&block);
6224 /* Check whether EXPR is a copyable array. */
6227 copyable_array_p (gfc_expr * expr)
6229 if (expr->expr_type != EXPR_VARIABLE)
6232 /* First check it's an array. */
6233 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6236 if (!gfc_full_array_ref_p (expr->ref, NULL))
6239 /* Next check that it's of a simple enough type. */
6240 switch (expr->ts.type)
6252 return !expr->ts.u.derived->attr.alloc_comp;
6261 /* Translate an assignment. */
6264 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6269 /* Special case a single function returning an array. */
6270 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6272 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6277 /* Special case assigning an array to zero. */
6278 if (copyable_array_p (expr1)
6279 && is_zero_initializer_p (expr2))
6281 tmp = gfc_trans_zero_assign (expr1);
6286 /* Special case copying one array to another. */
6287 if (copyable_array_p (expr1)
6288 && copyable_array_p (expr2)
6289 && gfc_compare_types (&expr1->ts, &expr2->ts)
6290 && !gfc_check_dependency (expr1, expr2, 0))
6292 tmp = gfc_trans_array_copy (expr1, expr2);
6297 /* Special case initializing an array from a constant array constructor. */
6298 if (copyable_array_p (expr1)
6299 && expr2->expr_type == EXPR_ARRAY
6300 && gfc_compare_types (&expr1->ts, &expr2->ts))
6302 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6307 /* Fallback to the scalarizer to generate explicit loops. */
6308 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6312 gfc_trans_init_assign (gfc_code * code)
6314 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6318 gfc_trans_assign (gfc_code * code)
6320 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6324 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6325 A MEMCPY is needed to copy the full data from the default initializer
6326 of the dynamic type. */
6329 gfc_trans_class_init_assign (gfc_code *code)
6333 gfc_se dst,src,memsz;
6334 gfc_expr *lhs,*rhs,*sz;
6336 gfc_start_block (&block);
6338 lhs = gfc_copy_expr (code->expr1);
6339 gfc_add_data_component (lhs);
6341 rhs = gfc_copy_expr (code->expr1);
6342 gfc_add_vptr_component (rhs);
6344 /* Make sure that the component backend_decls have been built, which
6345 will not have happened if the derived types concerned have not
6347 gfc_get_derived_type (rhs->ts.u.derived);
6348 gfc_add_def_init_component (rhs);
6350 sz = gfc_copy_expr (code->expr1);
6351 gfc_add_vptr_component (sz);
6352 gfc_add_size_component (sz);
6354 gfc_init_se (&dst, NULL);
6355 gfc_init_se (&src, NULL);
6356 gfc_init_se (&memsz, NULL);
6357 gfc_conv_expr (&dst, lhs);
6358 gfc_conv_expr (&src, rhs);
6359 gfc_conv_expr (&memsz, sz);
6360 gfc_add_block_to_block (&block, &src.pre);
6361 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6362 gfc_add_expr_to_block (&block, tmp);
6364 return gfc_finish_block (&block);
6368 /* Translate an assignment to a CLASS object
6369 (pointer or ordinary assignment). */
6372 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6379 gfc_start_block (&block);
6381 if (expr2->ts.type != BT_CLASS)
6383 /* Insert an additional assignment which sets the '_vptr' field. */
6384 gfc_symbol *vtab = NULL;
6387 lhs = gfc_copy_expr (expr1);
6388 gfc_add_vptr_component (lhs);
6390 if (expr2->ts.type == BT_DERIVED)
6391 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6392 else if (expr2->expr_type == EXPR_NULL)
6393 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6396 rhs = gfc_get_expr ();
6397 rhs->expr_type = EXPR_VARIABLE;
6398 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6402 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6403 gfc_add_expr_to_block (&block, tmp);
6405 gfc_free_expr (lhs);
6406 gfc_free_expr (rhs);
6409 /* Do the actual CLASS assignment. */
6410 if (expr2->ts.type == BT_CLASS)
6413 gfc_add_data_component (expr1);
6415 if (op == EXEC_ASSIGN)
6416 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6417 else if (op == EXEC_POINTER_ASSIGN)
6418 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6422 gfc_add_expr_to_block (&block, tmp);
6424 return gfc_finish_block (&block);