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;
3272 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3273 allocatable to an optional dummy, cf. 12.5.2.12. */
3274 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3275 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3276 goto end_pointer_check;
3280 /* If the actual argument is an optional pointer/allocatable and
3281 the formal argument takes an nonpointer optional value,
3282 it is invalid to pass a non-present argument on, even
3283 though there is no technical reason for this in gfortran.
3284 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3285 tree present, null_ptr, type;
3287 if (attr.allocatable
3288 && (fsym == NULL || !fsym->attr.allocatable))
3289 asprintf (&msg, "Allocatable actual argument '%s' is not "
3290 "allocated or not present", e->symtree->n.sym->name);
3291 else if (attr.pointer
3292 && (fsym == NULL || !fsym->attr.pointer))
3293 asprintf (&msg, "Pointer actual argument '%s' is not "
3294 "associated or not present",
3295 e->symtree->n.sym->name);
3296 else if (attr.proc_pointer
3297 && (fsym == NULL || !fsym->attr.proc_pointer))
3298 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3299 "associated or not present",
3300 e->symtree->n.sym->name);
3302 goto end_pointer_check;
3304 present = gfc_conv_expr_present (e->symtree->n.sym);
3305 type = TREE_TYPE (present);
3306 present = fold_build2_loc (input_location, EQ_EXPR,
3307 boolean_type_node, present,
3309 null_pointer_node));
3310 type = TREE_TYPE (parmse.expr);
3311 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3312 boolean_type_node, parmse.expr,
3314 null_pointer_node));
3315 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3316 boolean_type_node, present, null_ptr);
3320 if (attr.allocatable
3321 && (fsym == NULL || !fsym->attr.allocatable))
3322 asprintf (&msg, "Allocatable actual argument '%s' is not "
3323 "allocated", e->symtree->n.sym->name);
3324 else if (attr.pointer
3325 && (fsym == NULL || !fsym->attr.pointer))
3326 asprintf (&msg, "Pointer actual argument '%s' is not "
3327 "associated", e->symtree->n.sym->name);
3328 else if (attr.proc_pointer
3329 && (fsym == NULL || !fsym->attr.proc_pointer))
3330 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3331 "associated", e->symtree->n.sym->name);
3333 goto end_pointer_check;
3336 cond = fold_build2_loc (input_location, EQ_EXPR,
3337 boolean_type_node, parmse.expr,
3338 fold_convert (TREE_TYPE (parmse.expr),
3339 null_pointer_node));
3342 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3348 /* Deferred length dummies pass the character length by reference
3349 so that the value can be returned. */
3350 if (parmse.string_length && fsym && fsym->ts.deferred)
3352 tmp = parmse.string_length;
3353 if (TREE_CODE (tmp) != VAR_DECL)
3354 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3355 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3358 /* Character strings are passed as two parameters, a length and a
3359 pointer - except for Bind(c) which only passes the pointer. */
3360 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3361 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3363 VEC_safe_push (tree, gc, arglist, parmse.expr);
3365 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3372 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3373 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3374 else if (ts.type == BT_CHARACTER)
3376 if (ts.u.cl->length == NULL)
3378 /* Assumed character length results are not allowed by 5.1.1.5 of the
3379 standard and are trapped in resolve.c; except in the case of SPREAD
3380 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3381 we take the character length of the first argument for the result.
3382 For dummies, we have to look through the formal argument list for
3383 this function and use the character length found there.*/
3384 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3385 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3386 else if (!sym->attr.dummy)
3387 cl.backend_decl = VEC_index (tree, stringargs, 0);
3390 formal = sym->ns->proc_name->formal;
3391 for (; formal; formal = formal->next)
3392 if (strcmp (formal->sym->name, sym->name) == 0)
3393 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3400 /* Calculate the length of the returned string. */
3401 gfc_init_se (&parmse, NULL);
3402 if (need_interface_mapping)
3403 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3405 gfc_conv_expr (&parmse, ts.u.cl->length);
3406 gfc_add_block_to_block (&se->pre, &parmse.pre);
3407 gfc_add_block_to_block (&se->post, &parmse.post);
3409 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3410 tmp = fold_build2_loc (input_location, MAX_EXPR,
3411 gfc_charlen_type_node, tmp,
3412 build_int_cst (gfc_charlen_type_node, 0));
3413 cl.backend_decl = tmp;
3416 /* Set up a charlen structure for it. */
3421 len = cl.backend_decl;
3424 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3425 || (!comp && gfc_return_by_reference (sym));
3428 if (se->direct_byref)
3430 /* Sometimes, too much indirection can be applied; e.g. for
3431 function_result = array_valued_recursive_function. */
3432 if (TREE_TYPE (TREE_TYPE (se->expr))
3433 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3434 && GFC_DESCRIPTOR_TYPE_P
3435 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3436 se->expr = build_fold_indirect_ref_loc (input_location,
3439 /* If the lhs of an assignment x = f(..) is allocatable and
3440 f2003 is allowed, we must do the automatic reallocation.
3441 TODO - deal with intrinsics, without using a temporary. */
3442 if (gfc_option.flag_realloc_lhs
3443 && se->ss && se->ss->loop_chain
3444 && se->ss->loop_chain->is_alloc_lhs
3445 && !expr->value.function.isym
3446 && sym->result->as != NULL)
3448 /* Evaluate the bounds of the result, if known. */
3449 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3452 /* Perform the automatic reallocation. */
3453 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3455 gfc_add_expr_to_block (&se->pre, tmp);
3457 /* Pass the temporary as the first argument. */
3458 result = info->descriptor;
3461 result = build_fold_indirect_ref_loc (input_location,
3463 VEC_safe_push (tree, gc, retargs, se->expr);
3465 else if (comp && comp->attr.dimension)
3467 gcc_assert (se->loop && info);
3469 /* Set the type of the array. */
3470 tmp = gfc_typenode_for_spec (&comp->ts);
3471 info->dimen = se->loop->dimen;
3473 /* Evaluate the bounds of the result, if known. */
3474 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3476 /* If the lhs of an assignment x = f(..) is allocatable and
3477 f2003 is allowed, we must not generate the function call
3478 here but should just send back the results of the mapping.
3479 This is signalled by the function ss being flagged. */
3480 if (gfc_option.flag_realloc_lhs
3481 && se->ss && se->ss->is_alloc_lhs)
3483 gfc_free_interface_mapping (&mapping);
3484 return has_alternate_specifier;
3487 /* Create a temporary to store the result. In case the function
3488 returns a pointer, the temporary will be a shallow copy and
3489 mustn't be deallocated. */
3490 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3491 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3492 NULL_TREE, false, !comp->attr.pointer,
3493 callee_alloc, &se->ss->expr->where);
3495 /* Pass the temporary as the first argument. */
3496 result = info->descriptor;
3497 tmp = gfc_build_addr_expr (NULL_TREE, result);
3498 VEC_safe_push (tree, gc, retargs, tmp);
3500 else if (!comp && sym->result->attr.dimension)
3502 gcc_assert (se->loop && info);
3504 /* Set the type of the array. */
3505 tmp = gfc_typenode_for_spec (&ts);
3506 info->dimen = se->loop->dimen;
3508 /* Evaluate the bounds of the result, if known. */
3509 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3511 /* If the lhs of an assignment x = f(..) is allocatable and
3512 f2003 is allowed, we must not generate the function call
3513 here but should just send back the results of the mapping.
3514 This is signalled by the function ss being flagged. */
3515 if (gfc_option.flag_realloc_lhs
3516 && se->ss && se->ss->is_alloc_lhs)
3518 gfc_free_interface_mapping (&mapping);
3519 return has_alternate_specifier;
3522 /* Create a temporary to store the result. In case the function
3523 returns a pointer, the temporary will be a shallow copy and
3524 mustn't be deallocated. */
3525 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3526 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3527 NULL_TREE, false, !sym->attr.pointer,
3528 callee_alloc, &se->ss->expr->where);
3530 /* Pass the temporary as the first argument. */
3531 result = info->descriptor;
3532 tmp = gfc_build_addr_expr (NULL_TREE, result);
3533 VEC_safe_push (tree, gc, retargs, tmp);
3535 else if (ts.type == BT_CHARACTER)
3537 /* Pass the string length. */
3538 type = gfc_get_character_type (ts.kind, ts.u.cl);
3539 type = build_pointer_type (type);
3541 /* Return an address to a char[0:len-1]* temporary for
3542 character pointers. */
3543 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3544 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3546 var = gfc_create_var (type, "pstr");
3548 if ((!comp && sym->attr.allocatable)
3549 || (comp && comp->attr.allocatable))
3550 gfc_add_modify (&se->pre, var,
3551 fold_convert (TREE_TYPE (var),
3552 null_pointer_node));
3554 /* Provide an address expression for the function arguments. */
3555 var = gfc_build_addr_expr (NULL_TREE, var);
3558 var = gfc_conv_string_tmp (se, type, len);
3560 VEC_safe_push (tree, gc, retargs, var);
3564 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3566 type = gfc_get_complex_type (ts.kind);
3567 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3568 VEC_safe_push (tree, gc, retargs, var);
3571 if (ts.type == BT_CHARACTER && ts.deferred
3572 && (sym->attr.allocatable || sym->attr.pointer))
3575 if (TREE_CODE (tmp) != VAR_DECL)
3576 tmp = gfc_evaluate_now (len, &se->pre);
3577 len = gfc_build_addr_expr (NULL_TREE, tmp);
3580 /* Add the string length to the argument list. */
3581 if (ts.type == BT_CHARACTER)
3582 VEC_safe_push (tree, gc, retargs, len);
3584 gfc_free_interface_mapping (&mapping);
3586 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3587 arglen = (VEC_length (tree, arglist)
3588 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3589 VEC_reserve_exact (tree, gc, retargs, arglen);
3591 /* Add the return arguments. */
3592 VEC_splice (tree, retargs, arglist);
3594 /* Add the hidden string length parameters to the arguments. */
3595 VEC_splice (tree, retargs, stringargs);
3597 /* We may want to append extra arguments here. This is used e.g. for
3598 calls to libgfortran_matmul_??, which need extra information. */
3599 if (!VEC_empty (tree, append_args))
3600 VEC_splice (tree, retargs, append_args);
3603 /* Generate the actual call. */
3604 conv_function_val (se, sym, expr);
3606 /* If there are alternate return labels, function type should be
3607 integer. Can't modify the type in place though, since it can be shared
3608 with other functions. For dummy arguments, the typing is done to
3609 this result, even if it has to be repeated for each call. */
3610 if (has_alternate_specifier
3611 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3613 if (!sym->attr.dummy)
3615 TREE_TYPE (sym->backend_decl)
3616 = build_function_type (integer_type_node,
3617 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3618 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3621 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3624 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3625 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3627 /* If we have a pointer function, but we don't want a pointer, e.g.
3630 where f is pointer valued, we have to dereference the result. */
3631 if (!se->want_pointer && !byref
3632 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3633 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3634 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3636 /* f2c calling conventions require a scalar default real function to
3637 return a double precision result. Convert this back to default
3638 real. We only care about the cases that can happen in Fortran 77.
3640 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3641 && sym->ts.kind == gfc_default_real_kind
3642 && !sym->attr.always_explicit)
3643 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3645 /* A pure function may still have side-effects - it may modify its
3647 TREE_SIDE_EFFECTS (se->expr) = 1;
3649 if (!sym->attr.pure)
3650 TREE_SIDE_EFFECTS (se->expr) = 1;
3655 /* Add the function call to the pre chain. There is no expression. */
3656 gfc_add_expr_to_block (&se->pre, se->expr);
3657 se->expr = NULL_TREE;
3659 if (!se->direct_byref)
3661 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3663 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3665 /* Check the data pointer hasn't been modified. This would
3666 happen in a function returning a pointer. */
3667 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3668 tmp = fold_build2_loc (input_location, NE_EXPR,
3671 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3674 se->expr = info->descriptor;
3675 /* Bundle in the string length. */
3676 se->string_length = len;
3678 else if (ts.type == BT_CHARACTER)
3680 /* Dereference for character pointer results. */
3681 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3682 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3683 se->expr = build_fold_indirect_ref_loc (input_location, var);
3688 se->string_length = len;
3689 else if (sym->attr.allocatable || sym->attr.pointer)
3690 se->string_length = cl.backend_decl;
3694 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3695 se->expr = build_fold_indirect_ref_loc (input_location, var);
3700 /* Follow the function call with the argument post block. */
3703 gfc_add_block_to_block (&se->pre, &post);
3705 /* Transformational functions of derived types with allocatable
3706 components must have the result allocatable components copied. */
3707 arg = expr->value.function.actual;
3708 if (result && arg && expr->rank
3709 && expr->value.function.isym
3710 && expr->value.function.isym->transformational
3711 && arg->expr->ts.type == BT_DERIVED
3712 && arg->expr->ts.u.derived->attr.alloc_comp)
3715 /* Copy the allocatable components. We have to use a
3716 temporary here to prevent source allocatable components
3717 from being corrupted. */
3718 tmp2 = gfc_evaluate_now (result, &se->pre);
3719 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3720 result, tmp2, expr->rank);
3721 gfc_add_expr_to_block (&se->pre, tmp);
3722 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3724 gfc_add_expr_to_block (&se->pre, tmp);
3726 /* Finally free the temporary's data field. */
3727 tmp = gfc_conv_descriptor_data_get (tmp2);
3728 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3729 gfc_add_expr_to_block (&se->pre, tmp);
3733 gfc_add_block_to_block (&se->post, &post);
3735 return has_alternate_specifier;
3739 /* Fill a character string with spaces. */
3742 fill_with_spaces (tree start, tree type, tree size)
3744 stmtblock_t block, loop;
3745 tree i, el, exit_label, cond, tmp;
3747 /* For a simple char type, we can call memset(). */
3748 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3749 return build_call_expr_loc (input_location,
3750 built_in_decls[BUILT_IN_MEMSET], 3, start,
3751 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3752 lang_hooks.to_target_charset (' ')),
3755 /* Otherwise, we use a loop:
3756 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3760 /* Initialize variables. */
3761 gfc_init_block (&block);
3762 i = gfc_create_var (sizetype, "i");
3763 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3764 el = gfc_create_var (build_pointer_type (type), "el");
3765 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3766 exit_label = gfc_build_label_decl (NULL_TREE);
3767 TREE_USED (exit_label) = 1;
3771 gfc_init_block (&loop);
3773 /* Exit condition. */
3774 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3775 build_zero_cst (sizetype));
3776 tmp = build1_v (GOTO_EXPR, exit_label);
3777 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3778 build_empty_stmt (input_location));
3779 gfc_add_expr_to_block (&loop, tmp);
3782 gfc_add_modify (&loop,
3783 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3784 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3786 /* Increment loop variables. */
3787 gfc_add_modify (&loop, i,
3788 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3789 TYPE_SIZE_UNIT (type)));
3790 gfc_add_modify (&loop, el,
3791 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3792 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3794 /* Making the loop... actually loop! */
3795 tmp = gfc_finish_block (&loop);
3796 tmp = build1_v (LOOP_EXPR, tmp);
3797 gfc_add_expr_to_block (&block, tmp);
3799 /* The exit label. */
3800 tmp = build1_v (LABEL_EXPR, exit_label);
3801 gfc_add_expr_to_block (&block, tmp);
3804 return gfc_finish_block (&block);
3808 /* Generate code to copy a string. */
3811 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3812 int dkind, tree slength, tree src, int skind)
3814 tree tmp, dlen, slen;
3823 stmtblock_t tempblock;
3825 gcc_assert (dkind == skind);
3827 if (slength != NULL_TREE)
3829 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3830 ssc = gfc_string_to_single_character (slen, src, skind);
3834 slen = build_int_cst (size_type_node, 1);
3838 if (dlength != NULL_TREE)
3840 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3841 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3845 dlen = build_int_cst (size_type_node, 1);
3849 /* Assign directly if the types are compatible. */
3850 if (dsc != NULL_TREE && ssc != NULL_TREE
3851 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3853 gfc_add_modify (block, dsc, ssc);
3857 /* Do nothing if the destination length is zero. */
3858 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3859 build_int_cst (size_type_node, 0));
3861 /* The following code was previously in _gfortran_copy_string:
3863 // The two strings may overlap so we use memmove.
3865 copy_string (GFC_INTEGER_4 destlen, char * dest,
3866 GFC_INTEGER_4 srclen, const char * src)
3868 if (srclen >= destlen)
3870 // This will truncate if too long.
3871 memmove (dest, src, destlen);
3875 memmove (dest, src, srclen);
3877 memset (&dest[srclen], ' ', destlen - srclen);
3881 We're now doing it here for better optimization, but the logic
3884 /* For non-default character kinds, we have to multiply the string
3885 length by the base type size. */
3886 chartype = gfc_get_char_type (dkind);
3887 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3888 fold_convert (size_type_node, slen),
3889 fold_convert (size_type_node,
3890 TYPE_SIZE_UNIT (chartype)));
3891 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3892 fold_convert (size_type_node, dlen),
3893 fold_convert (size_type_node,
3894 TYPE_SIZE_UNIT (chartype)));
3896 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3897 dest = fold_convert (pvoid_type_node, dest);
3899 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3901 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3902 src = fold_convert (pvoid_type_node, src);
3904 src = gfc_build_addr_expr (pvoid_type_node, src);
3906 /* Truncate string if source is too long. */
3907 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3909 tmp2 = build_call_expr_loc (input_location,
3910 built_in_decls[BUILT_IN_MEMMOVE],
3911 3, dest, src, dlen);
3913 /* Else copy and pad with spaces. */
3914 tmp3 = build_call_expr_loc (input_location,
3915 built_in_decls[BUILT_IN_MEMMOVE],
3916 3, dest, src, slen);
3918 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3919 dest, fold_convert (sizetype, slen));
3920 tmp4 = fill_with_spaces (tmp4, chartype,
3921 fold_build2_loc (input_location, MINUS_EXPR,
3922 TREE_TYPE(dlen), dlen, slen));
3924 gfc_init_block (&tempblock);
3925 gfc_add_expr_to_block (&tempblock, tmp3);
3926 gfc_add_expr_to_block (&tempblock, tmp4);
3927 tmp3 = gfc_finish_block (&tempblock);
3929 /* The whole copy_string function is there. */
3930 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3932 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3933 build_empty_stmt (input_location));
3934 gfc_add_expr_to_block (block, tmp);
3938 /* Translate a statement function.
3939 The value of a statement function reference is obtained by evaluating the
3940 expression using the values of the actual arguments for the values of the
3941 corresponding dummy arguments. */
3944 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3948 gfc_formal_arglist *fargs;
3949 gfc_actual_arglist *args;
3952 gfc_saved_var *saved_vars;
3958 sym = expr->symtree->n.sym;
3959 args = expr->value.function.actual;
3960 gfc_init_se (&lse, NULL);
3961 gfc_init_se (&rse, NULL);
3964 for (fargs = sym->formal; fargs; fargs = fargs->next)
3966 saved_vars = XCNEWVEC (gfc_saved_var, n);
3967 temp_vars = XCNEWVEC (tree, n);
3969 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3971 /* Each dummy shall be specified, explicitly or implicitly, to be
3973 gcc_assert (fargs->sym->attr.dimension == 0);
3976 if (fsym->ts.type == BT_CHARACTER)
3978 /* Copy string arguments. */
3981 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3982 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3984 /* Create a temporary to hold the value. */
3985 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3986 fsym->ts.u.cl->backend_decl
3987 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3989 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3990 temp_vars[n] = gfc_create_var (type, fsym->name);
3992 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3994 gfc_conv_expr (&rse, args->expr);
3995 gfc_conv_string_parameter (&rse);
3996 gfc_add_block_to_block (&se->pre, &lse.pre);
3997 gfc_add_block_to_block (&se->pre, &rse.pre);
3999 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4000 rse.string_length, rse.expr, fsym->ts.kind);
4001 gfc_add_block_to_block (&se->pre, &lse.post);
4002 gfc_add_block_to_block (&se->pre, &rse.post);
4006 /* For everything else, just evaluate the expression. */
4008 /* Create a temporary to hold the value. */
4009 type = gfc_typenode_for_spec (&fsym->ts);
4010 temp_vars[n] = gfc_create_var (type, fsym->name);
4012 gfc_conv_expr (&lse, args->expr);
4014 gfc_add_block_to_block (&se->pre, &lse.pre);
4015 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4016 gfc_add_block_to_block (&se->pre, &lse.post);
4022 /* Use the temporary variables in place of the real ones. */
4023 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4024 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4026 gfc_conv_expr (se, sym->value);
4028 if (sym->ts.type == BT_CHARACTER)
4030 gfc_conv_const_charlen (sym->ts.u.cl);
4032 /* Force the expression to the correct length. */
4033 if (!INTEGER_CST_P (se->string_length)
4034 || tree_int_cst_lt (se->string_length,
4035 sym->ts.u.cl->backend_decl))
4037 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4038 tmp = gfc_create_var (type, sym->name);
4039 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4040 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4041 sym->ts.kind, se->string_length, se->expr,
4045 se->string_length = sym->ts.u.cl->backend_decl;
4048 /* Restore the original variables. */
4049 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4050 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4055 /* Translate a function expression. */
4058 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4062 if (expr->value.function.isym)
4064 gfc_conv_intrinsic_function (se, expr);
4068 /* We distinguish statement functions from general functions to improve
4069 runtime performance. */
4070 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4072 gfc_conv_statement_function (se, expr);
4076 /* expr.value.function.esym is the resolved (specific) function symbol for
4077 most functions. However this isn't set for dummy procedures. */
4078 sym = expr->value.function.esym;
4080 sym = expr->symtree->n.sym;
4082 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4086 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4089 is_zero_initializer_p (gfc_expr * expr)
4091 if (expr->expr_type != EXPR_CONSTANT)
4094 /* We ignore constants with prescribed memory representations for now. */
4095 if (expr->representation.string)
4098 switch (expr->ts.type)
4101 return mpz_cmp_si (expr->value.integer, 0) == 0;
4104 return mpfr_zero_p (expr->value.real)
4105 && MPFR_SIGN (expr->value.real) >= 0;
4108 return expr->value.logical == 0;
4111 return mpfr_zero_p (mpc_realref (expr->value.complex))
4112 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4113 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4114 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4124 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4126 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4127 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4129 gfc_conv_tmp_array_ref (se);
4133 /* Build a static initializer. EXPR is the expression for the initial value.
4134 The other parameters describe the variable of the component being
4135 initialized. EXPR may be null. */
4138 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4139 bool array, bool pointer, bool procptr)
4143 if (!(expr || pointer || procptr))
4146 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4147 (these are the only two iso_c_binding derived types that can be
4148 used as initialization expressions). If so, we need to modify
4149 the 'expr' to be that for a (void *). */
4150 if (expr != NULL && expr->ts.type == BT_DERIVED
4151 && expr->ts.is_iso_c && expr->ts.u.derived)
4153 gfc_symbol *derived = expr->ts.u.derived;
4155 /* The derived symbol has already been converted to a (void *). Use
4157 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4158 expr->ts.f90_type = derived->ts.f90_type;
4160 gfc_init_se (&se, NULL);
4161 gfc_conv_constant (&se, expr);
4162 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4166 if (array && !procptr)
4169 /* Arrays need special handling. */
4171 ctor = gfc_build_null_descriptor (type);
4172 /* Special case assigning an array to zero. */
4173 else if (is_zero_initializer_p (expr))
4174 ctor = build_constructor (type, NULL);
4176 ctor = gfc_conv_array_initializer (type, expr);
4177 TREE_STATIC (ctor) = 1;
4180 else if (pointer || procptr)
4182 if (!expr || expr->expr_type == EXPR_NULL)
4183 return fold_convert (type, null_pointer_node);
4186 gfc_init_se (&se, NULL);
4187 se.want_pointer = 1;
4188 gfc_conv_expr (&se, expr);
4189 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4199 gfc_init_se (&se, NULL);
4200 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4201 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4203 gfc_conv_structure (&se, expr, 1);
4204 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4205 TREE_STATIC (se.expr) = 1;
4210 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4211 TREE_STATIC (ctor) = 1;
4216 gfc_init_se (&se, NULL);
4217 gfc_conv_constant (&se, expr);
4218 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4225 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4237 gfc_start_block (&block);
4239 /* Initialize the scalarizer. */
4240 gfc_init_loopinfo (&loop);
4242 gfc_init_se (&lse, NULL);
4243 gfc_init_se (&rse, NULL);
4246 rss = gfc_walk_expr (expr);
4247 if (rss == gfc_ss_terminator)
4249 /* The rhs is scalar. Add a ss for the expression. */
4250 rss = gfc_get_ss ();
4251 rss->next = gfc_ss_terminator;
4252 rss->type = GFC_SS_SCALAR;
4256 /* Create a SS for the destination. */
4257 lss = gfc_get_ss ();
4258 lss->type = GFC_SS_COMPONENT;
4260 lss->shape = gfc_get_shape (cm->as->rank);
4261 lss->next = gfc_ss_terminator;
4262 lss->data.info.dimen = cm->as->rank;
4263 lss->data.info.descriptor = dest;
4264 lss->data.info.data = gfc_conv_array_data (dest);
4265 lss->data.info.offset = gfc_conv_array_offset (dest);
4266 for (n = 0; n < cm->as->rank; n++)
4268 lss->data.info.dim[n] = n;
4269 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4270 lss->data.info.stride[n] = gfc_index_one_node;
4272 mpz_init (lss->shape[n]);
4273 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4274 cm->as->lower[n]->value.integer);
4275 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4278 /* Associate the SS with the loop. */
4279 gfc_add_ss_to_loop (&loop, lss);
4280 gfc_add_ss_to_loop (&loop, rss);
4282 /* Calculate the bounds of the scalarization. */
4283 gfc_conv_ss_startstride (&loop);
4285 /* Setup the scalarizing loops. */
4286 gfc_conv_loop_setup (&loop, &expr->where);
4288 /* Setup the gfc_se structures. */
4289 gfc_copy_loopinfo_to_se (&lse, &loop);
4290 gfc_copy_loopinfo_to_se (&rse, &loop);
4293 gfc_mark_ss_chain_used (rss, 1);
4295 gfc_mark_ss_chain_used (lss, 1);
4297 /* Start the scalarized loop body. */
4298 gfc_start_scalarized_body (&loop, &body);
4300 gfc_conv_tmp_array_ref (&lse);
4301 if (cm->ts.type == BT_CHARACTER)
4302 lse.string_length = cm->ts.u.cl->backend_decl;
4304 gfc_conv_expr (&rse, expr);
4306 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4307 gfc_add_expr_to_block (&body, tmp);
4309 gcc_assert (rse.ss == gfc_ss_terminator);
4311 /* Generate the copying loops. */
4312 gfc_trans_scalarizing_loops (&loop, &body);
4314 /* Wrap the whole thing up. */
4315 gfc_add_block_to_block (&block, &loop.pre);
4316 gfc_add_block_to_block (&block, &loop.post);
4318 for (n = 0; n < cm->as->rank; n++)
4319 mpz_clear (lss->shape[n]);
4322 gfc_cleanup_loop (&loop);
4324 return gfc_finish_block (&block);
4329 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4340 gfc_expr *arg = NULL;
4342 gfc_start_block (&block);
4343 gfc_init_se (&se, NULL);
4345 /* Get the descriptor for the expressions. */
4346 rss = gfc_walk_expr (expr);
4347 se.want_pointer = 0;
4348 gfc_conv_expr_descriptor (&se, expr, rss);
4349 gfc_add_block_to_block (&block, &se.pre);
4350 gfc_add_modify (&block, dest, se.expr);
4352 /* Deal with arrays of derived types with allocatable components. */
4353 if (cm->ts.type == BT_DERIVED
4354 && cm->ts.u.derived->attr.alloc_comp)
4355 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4359 tmp = gfc_duplicate_allocatable (dest, se.expr,
4360 TREE_TYPE(cm->backend_decl),
4363 gfc_add_expr_to_block (&block, tmp);
4364 gfc_add_block_to_block (&block, &se.post);
4366 if (expr->expr_type != EXPR_VARIABLE)
4367 gfc_conv_descriptor_data_set (&block, se.expr,
4370 /* We need to know if the argument of a conversion function is a
4371 variable, so that the correct lower bound can be used. */
4372 if (expr->expr_type == EXPR_FUNCTION
4373 && expr->value.function.isym
4374 && expr->value.function.isym->conversion
4375 && expr->value.function.actual->expr
4376 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4377 arg = expr->value.function.actual->expr;
4379 /* Obtain the array spec of full array references. */
4381 as = gfc_get_full_arrayspec_from_expr (arg);
4383 as = gfc_get_full_arrayspec_from_expr (expr);
4385 /* Shift the lbound and ubound of temporaries to being unity,
4386 rather than zero, based. Always calculate the offset. */
4387 offset = gfc_conv_descriptor_offset_get (dest);
4388 gfc_add_modify (&block, offset, gfc_index_zero_node);
4389 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4391 for (n = 0; n < expr->rank; n++)
4396 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4397 TODO It looks as if gfc_conv_expr_descriptor should return
4398 the correct bounds and that the following should not be
4399 necessary. This would simplify gfc_conv_intrinsic_bound
4401 if (as && as->lower[n])
4404 gfc_init_se (&lbse, NULL);
4405 gfc_conv_expr (&lbse, as->lower[n]);
4406 gfc_add_block_to_block (&block, &lbse.pre);
4407 lbound = gfc_evaluate_now (lbse.expr, &block);
4411 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4412 lbound = gfc_conv_descriptor_lbound_get (tmp,
4416 lbound = gfc_conv_descriptor_lbound_get (dest,
4419 lbound = gfc_index_one_node;
4421 lbound = fold_convert (gfc_array_index_type, lbound);
4423 /* Shift the bounds and set the offset accordingly. */
4424 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4425 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4426 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4427 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4429 gfc_conv_descriptor_ubound_set (&block, dest,
4430 gfc_rank_cst[n], tmp);
4431 gfc_conv_descriptor_lbound_set (&block, dest,
4432 gfc_rank_cst[n], lbound);
4434 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4435 gfc_conv_descriptor_lbound_get (dest,
4437 gfc_conv_descriptor_stride_get (dest,
4439 gfc_add_modify (&block, tmp2, tmp);
4440 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4442 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4447 /* If a conversion expression has a null data pointer
4448 argument, nullify the allocatable component. */
4452 if (arg->symtree->n.sym->attr.allocatable
4453 || arg->symtree->n.sym->attr.pointer)
4455 non_null_expr = gfc_finish_block (&block);
4456 gfc_start_block (&block);
4457 gfc_conv_descriptor_data_set (&block, dest,
4459 null_expr = gfc_finish_block (&block);
4460 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4461 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4462 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4463 return build3_v (COND_EXPR, tmp,
4464 null_expr, non_null_expr);
4468 return gfc_finish_block (&block);
4472 /* Assign a single component of a derived type constructor. */
4475 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4483 gfc_start_block (&block);
4485 if (cm->attr.pointer)
4487 gfc_init_se (&se, NULL);
4488 /* Pointer component. */
4489 if (cm->attr.dimension)
4491 /* Array pointer. */
4492 if (expr->expr_type == EXPR_NULL)
4493 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4496 rss = gfc_walk_expr (expr);
4497 se.direct_byref = 1;
4499 gfc_conv_expr_descriptor (&se, expr, rss);
4500 gfc_add_block_to_block (&block, &se.pre);
4501 gfc_add_block_to_block (&block, &se.post);
4506 /* Scalar pointers. */
4507 se.want_pointer = 1;
4508 gfc_conv_expr (&se, expr);
4509 gfc_add_block_to_block (&block, &se.pre);
4510 gfc_add_modify (&block, dest,
4511 fold_convert (TREE_TYPE (dest), se.expr));
4512 gfc_add_block_to_block (&block, &se.post);
4515 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4517 /* NULL initialization for CLASS components. */
4518 tmp = gfc_trans_structure_assign (dest,
4519 gfc_class_null_initializer (&cm->ts));
4520 gfc_add_expr_to_block (&block, tmp);
4522 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4524 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4525 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4526 else if (cm->attr.allocatable)
4528 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4529 gfc_add_expr_to_block (&block, tmp);
4533 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4534 gfc_add_expr_to_block (&block, tmp);
4537 else if (expr->ts.type == BT_DERIVED)
4539 if (expr->expr_type != EXPR_STRUCTURE)
4541 gfc_init_se (&se, NULL);
4542 gfc_conv_expr (&se, expr);
4543 gfc_add_block_to_block (&block, &se.pre);
4544 gfc_add_modify (&block, dest,
4545 fold_convert (TREE_TYPE (dest), se.expr));
4546 gfc_add_block_to_block (&block, &se.post);
4550 /* Nested constructors. */
4551 tmp = gfc_trans_structure_assign (dest, expr);
4552 gfc_add_expr_to_block (&block, tmp);
4557 /* Scalar component. */
4558 gfc_init_se (&se, NULL);
4559 gfc_init_se (&lse, NULL);
4561 gfc_conv_expr (&se, expr);
4562 if (cm->ts.type == BT_CHARACTER)
4563 lse.string_length = cm->ts.u.cl->backend_decl;
4565 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4566 gfc_add_expr_to_block (&block, tmp);
4568 return gfc_finish_block (&block);
4571 /* Assign a derived type constructor to a variable. */
4574 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4582 gfc_start_block (&block);
4583 cm = expr->ts.u.derived->components;
4585 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4586 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4587 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4591 gcc_assert (cm->backend_decl == NULL);
4592 gfc_init_se (&se, NULL);
4593 gfc_init_se (&lse, NULL);
4594 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4596 gfc_add_modify (&block, lse.expr,
4597 fold_convert (TREE_TYPE (lse.expr), se.expr));
4599 return gfc_finish_block (&block);
4602 for (c = gfc_constructor_first (expr->value.constructor);
4603 c; c = gfc_constructor_next (c), cm = cm->next)
4605 /* Skip absent members in default initializers. */
4609 field = cm->backend_decl;
4610 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4611 dest, field, NULL_TREE);
4612 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4613 gfc_add_expr_to_block (&block, tmp);
4615 return gfc_finish_block (&block);
4618 /* Build an expression for a constructor. If init is nonzero then
4619 this is part of a static variable initializer. */
4622 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4629 VEC(constructor_elt,gc) *v = NULL;
4631 gcc_assert (se->ss == NULL);
4632 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4633 type = gfc_typenode_for_spec (&expr->ts);
4637 /* Create a temporary variable and fill it in. */
4638 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4639 tmp = gfc_trans_structure_assign (se->expr, expr);
4640 gfc_add_expr_to_block (&se->pre, tmp);
4644 cm = expr->ts.u.derived->components;
4646 for (c = gfc_constructor_first (expr->value.constructor);
4647 c; c = gfc_constructor_next (c), cm = cm->next)
4649 /* Skip absent members in default initializers and allocatable
4650 components. Although the latter have a default initializer
4651 of EXPR_NULL,... by default, the static nullify is not needed
4652 since this is done every time we come into scope. */
4653 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4656 if (strcmp (cm->name, "_size") == 0)
4658 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4659 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4661 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4662 && strcmp (cm->name, "_extends") == 0)
4666 vtabs = cm->initializer->symtree->n.sym;
4667 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4668 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4672 val = gfc_conv_initializer (c->expr, &cm->ts,
4673 TREE_TYPE (cm->backend_decl),
4674 cm->attr.dimension, cm->attr.pointer,
4675 cm->attr.proc_pointer);
4677 /* Append it to the constructor list. */
4678 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4681 se->expr = build_constructor (type, v);
4683 TREE_CONSTANT (se->expr) = 1;
4687 /* Translate a substring expression. */
4690 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4696 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4698 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4699 expr->value.character.length,
4700 expr->value.character.string);
4702 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4703 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4706 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4710 /* Entry point for expression translation. Evaluates a scalar quantity.
4711 EXPR is the expression to be translated, and SE is the state structure if
4712 called from within the scalarized. */
4715 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4717 if (se->ss && se->ss->expr == expr
4718 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4720 /* Substitute a scalar expression evaluated outside the scalarization
4722 se->expr = se->ss->data.scalar.expr;
4723 if (se->ss->type == GFC_SS_REFERENCE)
4724 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4725 se->string_length = se->ss->string_length;
4726 gfc_advance_se_ss_chain (se);
4730 /* We need to convert the expressions for the iso_c_binding derived types.
4731 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4732 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4733 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4734 updated to be an integer with a kind equal to the size of a (void *). */
4735 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4736 && expr->ts.u.derived->attr.is_iso_c)
4738 if (expr->expr_type == EXPR_VARIABLE
4739 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4740 || expr->symtree->n.sym->intmod_sym_id
4741 == ISOCBINDING_NULL_FUNPTR))
4743 /* Set expr_type to EXPR_NULL, which will result in
4744 null_pointer_node being used below. */
4745 expr->expr_type = EXPR_NULL;
4749 /* Update the type/kind of the expression to be what the new
4750 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4751 expr->ts.type = expr->ts.u.derived->ts.type;
4752 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4753 expr->ts.kind = expr->ts.u.derived->ts.kind;
4757 switch (expr->expr_type)
4760 gfc_conv_expr_op (se, expr);
4764 gfc_conv_function_expr (se, expr);
4768 gfc_conv_constant (se, expr);
4772 gfc_conv_variable (se, expr);
4776 se->expr = null_pointer_node;
4779 case EXPR_SUBSTRING:
4780 gfc_conv_substring_expr (se, expr);
4783 case EXPR_STRUCTURE:
4784 gfc_conv_structure (se, expr, 0);
4788 gfc_conv_array_constructor_expr (se, expr);
4797 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4798 of an assignment. */
4800 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4802 gfc_conv_expr (se, expr);
4803 /* All numeric lvalues should have empty post chains. If not we need to
4804 figure out a way of rewriting an lvalue so that it has no post chain. */
4805 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4808 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4809 numeric expressions. Used for scalar values where inserting cleanup code
4812 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4816 gcc_assert (expr->ts.type != BT_CHARACTER);
4817 gfc_conv_expr (se, expr);
4820 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4821 gfc_add_modify (&se->pre, val, se->expr);
4823 gfc_add_block_to_block (&se->pre, &se->post);
4827 /* Helper to translate an expression and convert it to a particular type. */
4829 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4831 gfc_conv_expr_val (se, expr);
4832 se->expr = convert (type, se->expr);
4836 /* Converts an expression so that it can be passed by reference. Scalar
4840 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4844 if (se->ss && se->ss->expr == expr
4845 && se->ss->type == GFC_SS_REFERENCE)
4847 /* Returns a reference to the scalar evaluated outside the loop
4849 gfc_conv_expr (se, expr);
4853 if (expr->ts.type == BT_CHARACTER)
4855 gfc_conv_expr (se, expr);
4856 gfc_conv_string_parameter (se);
4860 if (expr->expr_type == EXPR_VARIABLE)
4862 se->want_pointer = 1;
4863 gfc_conv_expr (se, expr);
4866 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4867 gfc_add_modify (&se->pre, var, se->expr);
4868 gfc_add_block_to_block (&se->pre, &se->post);
4874 if (expr->expr_type == EXPR_FUNCTION
4875 && ((expr->value.function.esym
4876 && expr->value.function.esym->result->attr.pointer
4877 && !expr->value.function.esym->result->attr.dimension)
4878 || (!expr->value.function.esym
4879 && expr->symtree->n.sym->attr.pointer
4880 && !expr->symtree->n.sym->attr.dimension)))
4882 se->want_pointer = 1;
4883 gfc_conv_expr (se, expr);
4884 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4885 gfc_add_modify (&se->pre, var, se->expr);
4891 gfc_conv_expr (se, expr);
4893 /* Create a temporary var to hold the value. */
4894 if (TREE_CONSTANT (se->expr))
4896 tree tmp = se->expr;
4897 STRIP_TYPE_NOPS (tmp);
4898 var = build_decl (input_location,
4899 CONST_DECL, NULL, TREE_TYPE (tmp));
4900 DECL_INITIAL (var) = tmp;
4901 TREE_STATIC (var) = 1;
4906 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4907 gfc_add_modify (&se->pre, var, se->expr);
4909 gfc_add_block_to_block (&se->pre, &se->post);
4911 /* Take the address of that value. */
4912 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4917 gfc_trans_pointer_assign (gfc_code * code)
4919 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4923 /* Generate code for a pointer assignment. */
4926 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4937 gfc_start_block (&block);
4939 gfc_init_se (&lse, NULL);
4941 lss = gfc_walk_expr (expr1);
4942 rss = gfc_walk_expr (expr2);
4943 if (lss == gfc_ss_terminator)
4945 /* Scalar pointers. */
4946 lse.want_pointer = 1;
4947 gfc_conv_expr (&lse, expr1);
4948 gcc_assert (rss == gfc_ss_terminator);
4949 gfc_init_se (&rse, NULL);
4950 rse.want_pointer = 1;
4951 gfc_conv_expr (&rse, expr2);
4953 if (expr1->symtree->n.sym->attr.proc_pointer
4954 && expr1->symtree->n.sym->attr.dummy)
4955 lse.expr = build_fold_indirect_ref_loc (input_location,
4958 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4959 && expr2->symtree->n.sym->attr.dummy)
4960 rse.expr = build_fold_indirect_ref_loc (input_location,
4963 gfc_add_block_to_block (&block, &lse.pre);
4964 gfc_add_block_to_block (&block, &rse.pre);
4966 /* Check character lengths if character expression. The test is only
4967 really added if -fbounds-check is enabled. Exclude deferred
4968 character length lefthand sides. */
4969 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4970 && !(expr1->ts.deferred
4971 && (TREE_CODE (lse.string_length) == VAR_DECL))
4972 && !expr1->symtree->n.sym->attr.proc_pointer
4973 && !gfc_is_proc_ptr_comp (expr1, NULL))
4975 gcc_assert (expr2->ts.type == BT_CHARACTER);
4976 gcc_assert (lse.string_length && rse.string_length);
4977 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4978 lse.string_length, rse.string_length,
4982 /* The assignment to an deferred character length sets the string
4983 length to that of the rhs. */
4984 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4986 if (expr2->expr_type != EXPR_NULL)
4987 gfc_add_modify (&block, lse.string_length, rse.string_length);
4989 gfc_add_modify (&block, lse.string_length,
4990 build_int_cst (gfc_charlen_type_node, 0));
4993 gfc_add_modify (&block, lse.expr,
4994 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4996 gfc_add_block_to_block (&block, &rse.post);
4997 gfc_add_block_to_block (&block, &lse.post);
5004 tree strlen_rhs = NULL_TREE;
5006 /* Array pointer. Find the last reference on the LHS and if it is an
5007 array section ref, we're dealing with bounds remapping. In this case,
5008 set it to AR_FULL so that gfc_conv_expr_descriptor does
5009 not see it and process the bounds remapping afterwards explicitely. */
5010 for (remap = expr1->ref; remap; remap = remap->next)
5011 if (!remap->next && remap->type == REF_ARRAY
5012 && remap->u.ar.type == AR_SECTION)
5014 remap->u.ar.type = AR_FULL;
5017 rank_remap = (remap && remap->u.ar.end[0]);
5019 gfc_conv_expr_descriptor (&lse, expr1, lss);
5020 strlen_lhs = lse.string_length;
5023 if (expr2->expr_type == EXPR_NULL)
5025 /* Just set the data pointer to null. */
5026 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5028 else if (rank_remap)
5030 /* If we are rank-remapping, just get the RHS's descriptor and
5031 process this later on. */
5032 gfc_init_se (&rse, NULL);
5033 rse.direct_byref = 1;
5034 rse.byref_noassign = 1;
5035 gfc_conv_expr_descriptor (&rse, expr2, rss);
5036 strlen_rhs = rse.string_length;
5038 else if (expr2->expr_type == EXPR_VARIABLE)
5040 /* Assign directly to the LHS's descriptor. */
5041 lse.direct_byref = 1;
5042 gfc_conv_expr_descriptor (&lse, expr2, rss);
5043 strlen_rhs = lse.string_length;
5045 /* If this is a subreference array pointer assignment, use the rhs
5046 descriptor element size for the lhs span. */
5047 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5049 decl = expr1->symtree->n.sym->backend_decl;
5050 gfc_init_se (&rse, NULL);
5051 rse.descriptor_only = 1;
5052 gfc_conv_expr (&rse, expr2);
5053 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5054 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5055 if (!INTEGER_CST_P (tmp))
5056 gfc_add_block_to_block (&lse.post, &rse.pre);
5057 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5062 /* Assign to a temporary descriptor and then copy that
5063 temporary to the pointer. */
5064 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5067 lse.direct_byref = 1;
5068 gfc_conv_expr_descriptor (&lse, expr2, rss);
5069 strlen_rhs = lse.string_length;
5070 gfc_add_modify (&lse.pre, desc, tmp);
5073 gfc_add_block_to_block (&block, &lse.pre);
5075 gfc_add_block_to_block (&block, &rse.pre);
5077 /* If we do bounds remapping, update LHS descriptor accordingly. */
5081 gcc_assert (remap->u.ar.dimen == expr1->rank);
5085 /* Do rank remapping. We already have the RHS's descriptor
5086 converted in rse and now have to build the correct LHS
5087 descriptor for it. */
5091 tree lbound, ubound;
5094 dtype = gfc_conv_descriptor_dtype (desc);
5095 tmp = gfc_get_dtype (TREE_TYPE (desc));
5096 gfc_add_modify (&block, dtype, tmp);
5098 /* Copy data pointer. */
5099 data = gfc_conv_descriptor_data_get (rse.expr);
5100 gfc_conv_descriptor_data_set (&block, desc, data);
5102 /* Copy offset but adjust it such that it would correspond
5103 to a lbound of zero. */
5104 offs = gfc_conv_descriptor_offset_get (rse.expr);
5105 for (dim = 0; dim < expr2->rank; ++dim)
5107 stride = gfc_conv_descriptor_stride_get (rse.expr,
5109 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5111 tmp = fold_build2_loc (input_location, MULT_EXPR,
5112 gfc_array_index_type, stride, lbound);
5113 offs = fold_build2_loc (input_location, PLUS_EXPR,
5114 gfc_array_index_type, offs, tmp);
5116 gfc_conv_descriptor_offset_set (&block, desc, offs);
5118 /* Set the bounds as declared for the LHS and calculate strides as
5119 well as another offset update accordingly. */
5120 stride = gfc_conv_descriptor_stride_get (rse.expr,
5122 for (dim = 0; dim < expr1->rank; ++dim)
5127 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5129 /* Convert declared bounds. */
5130 gfc_init_se (&lower_se, NULL);
5131 gfc_init_se (&upper_se, NULL);
5132 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5133 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5135 gfc_add_block_to_block (&block, &lower_se.pre);
5136 gfc_add_block_to_block (&block, &upper_se.pre);
5138 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5139 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5141 lbound = gfc_evaluate_now (lbound, &block);
5142 ubound = gfc_evaluate_now (ubound, &block);
5144 gfc_add_block_to_block (&block, &lower_se.post);
5145 gfc_add_block_to_block (&block, &upper_se.post);
5147 /* Set bounds in descriptor. */
5148 gfc_conv_descriptor_lbound_set (&block, desc,
5149 gfc_rank_cst[dim], lbound);
5150 gfc_conv_descriptor_ubound_set (&block, desc,
5151 gfc_rank_cst[dim], ubound);
5154 stride = gfc_evaluate_now (stride, &block);
5155 gfc_conv_descriptor_stride_set (&block, desc,
5156 gfc_rank_cst[dim], stride);
5158 /* Update offset. */
5159 offs = gfc_conv_descriptor_offset_get (desc);
5160 tmp = fold_build2_loc (input_location, MULT_EXPR,
5161 gfc_array_index_type, lbound, stride);
5162 offs = fold_build2_loc (input_location, MINUS_EXPR,
5163 gfc_array_index_type, offs, tmp);
5164 offs = gfc_evaluate_now (offs, &block);
5165 gfc_conv_descriptor_offset_set (&block, desc, offs);
5167 /* Update stride. */
5168 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5169 stride = fold_build2_loc (input_location, MULT_EXPR,
5170 gfc_array_index_type, stride, tmp);
5175 /* Bounds remapping. Just shift the lower bounds. */
5177 gcc_assert (expr1->rank == expr2->rank);
5179 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5183 gcc_assert (remap->u.ar.start[dim]);
5184 gcc_assert (!remap->u.ar.end[dim]);
5185 gfc_init_se (&lbound_se, NULL);
5186 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5188 gfc_add_block_to_block (&block, &lbound_se.pre);
5189 gfc_conv_shift_descriptor_lbound (&block, desc,
5190 dim, lbound_se.expr);
5191 gfc_add_block_to_block (&block, &lbound_se.post);
5196 /* Check string lengths if applicable. The check is only really added
5197 to the output code if -fbounds-check is enabled. */
5198 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5200 gcc_assert (expr2->ts.type == BT_CHARACTER);
5201 gcc_assert (strlen_lhs && strlen_rhs);
5202 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5203 strlen_lhs, strlen_rhs, &block);
5206 /* If rank remapping was done, check with -fcheck=bounds that
5207 the target is at least as large as the pointer. */
5208 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5214 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5215 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5217 lsize = gfc_evaluate_now (lsize, &block);
5218 rsize = gfc_evaluate_now (rsize, &block);
5219 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5222 msg = _("Target of rank remapping is too small (%ld < %ld)");
5223 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5227 gfc_add_block_to_block (&block, &lse.post);
5229 gfc_add_block_to_block (&block, &rse.post);
5232 return gfc_finish_block (&block);
5236 /* Makes sure se is suitable for passing as a function string parameter. */
5237 /* TODO: Need to check all callers of this function. It may be abused. */
5240 gfc_conv_string_parameter (gfc_se * se)
5244 if (TREE_CODE (se->expr) == STRING_CST)
5246 type = TREE_TYPE (TREE_TYPE (se->expr));
5247 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5251 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5253 if (TREE_CODE (se->expr) != INDIRECT_REF)
5255 type = TREE_TYPE (se->expr);
5256 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5260 type = gfc_get_character_type_len (gfc_default_character_kind,
5262 type = build_pointer_type (type);
5263 se->expr = gfc_build_addr_expr (type, se->expr);
5267 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5271 /* Generate code for assignment of scalar variables. Includes character
5272 strings and derived types with allocatable components.
5273 If you know that the LHS has no allocations, set dealloc to false. */
5276 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5277 bool l_is_temp, bool r_is_var, bool dealloc)
5283 gfc_init_block (&block);
5285 if (ts.type == BT_CHARACTER)
5290 if (lse->string_length != NULL_TREE)
5292 gfc_conv_string_parameter (lse);
5293 gfc_add_block_to_block (&block, &lse->pre);
5294 llen = lse->string_length;
5297 if (rse->string_length != NULL_TREE)
5299 gcc_assert (rse->string_length != NULL_TREE);
5300 gfc_conv_string_parameter (rse);
5301 gfc_add_block_to_block (&block, &rse->pre);
5302 rlen = rse->string_length;
5305 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5306 rse->expr, ts.kind);
5308 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5312 /* Are the rhs and the lhs the same? */
5315 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5316 gfc_build_addr_expr (NULL_TREE, lse->expr),
5317 gfc_build_addr_expr (NULL_TREE, rse->expr));
5318 cond = gfc_evaluate_now (cond, &lse->pre);
5321 /* Deallocate the lhs allocated components as long as it is not
5322 the same as the rhs. This must be done following the assignment
5323 to prevent deallocating data that could be used in the rhs
5325 if (!l_is_temp && dealloc)
5327 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5328 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5330 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5332 gfc_add_expr_to_block (&lse->post, tmp);
5335 gfc_add_block_to_block (&block, &rse->pre);
5336 gfc_add_block_to_block (&block, &lse->pre);
5338 gfc_add_modify (&block, lse->expr,
5339 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5341 /* Do a deep copy if the rhs is a variable, if it is not the
5345 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5346 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5348 gfc_add_expr_to_block (&block, tmp);
5351 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5353 gfc_add_block_to_block (&block, &lse->pre);
5354 gfc_add_block_to_block (&block, &rse->pre);
5355 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5356 TREE_TYPE (lse->expr), rse->expr);
5357 gfc_add_modify (&block, lse->expr, tmp);
5361 gfc_add_block_to_block (&block, &lse->pre);
5362 gfc_add_block_to_block (&block, &rse->pre);
5364 gfc_add_modify (&block, lse->expr,
5365 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5368 gfc_add_block_to_block (&block, &lse->post);
5369 gfc_add_block_to_block (&block, &rse->post);
5371 return gfc_finish_block (&block);
5375 /* There are quite a lot of restrictions on the optimisation in using an
5376 array function assign without a temporary. */
5379 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5382 bool seen_array_ref;
5384 gfc_symbol *sym = expr1->symtree->n.sym;
5386 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5387 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5390 /* Elemental functions are scalarized so that they don't need a
5391 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5392 they would need special treatment in gfc_trans_arrayfunc_assign. */
5393 if (expr2->value.function.esym != NULL
5394 && expr2->value.function.esym->attr.elemental)
5397 /* Need a temporary if rhs is not FULL or a contiguous section. */
5398 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5401 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5402 if (gfc_ref_needs_temporary_p (expr1->ref))
5405 /* Functions returning pointers or allocatables need temporaries. */
5406 c = expr2->value.function.esym
5407 ? (expr2->value.function.esym->attr.pointer
5408 || expr2->value.function.esym->attr.allocatable)
5409 : (expr2->symtree->n.sym->attr.pointer
5410 || expr2->symtree->n.sym->attr.allocatable);
5414 /* Character array functions need temporaries unless the
5415 character lengths are the same. */
5416 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5418 if (expr1->ts.u.cl->length == NULL
5419 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5422 if (expr2->ts.u.cl->length == NULL
5423 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5426 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5427 expr2->ts.u.cl->length->value.integer) != 0)
5431 /* Check that no LHS component references appear during an array
5432 reference. This is needed because we do not have the means to
5433 span any arbitrary stride with an array descriptor. This check
5434 is not needed for the rhs because the function result has to be
5436 seen_array_ref = false;
5437 for (ref = expr1->ref; ref; ref = ref->next)
5439 if (ref->type == REF_ARRAY)
5440 seen_array_ref= true;
5441 else if (ref->type == REF_COMPONENT && seen_array_ref)
5445 /* Check for a dependency. */
5446 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5447 expr2->value.function.esym,
5448 expr2->value.function.actual,
5452 /* If we have reached here with an intrinsic function, we do not
5453 need a temporary except in the particular case that reallocation
5454 on assignment is active and the lhs is allocatable and a target. */
5455 if (expr2->value.function.isym)
5456 return (gfc_option.flag_realloc_lhs
5457 && sym->attr.allocatable
5458 && sym->attr.target);
5460 /* If the LHS is a dummy, we need a temporary if it is not
5462 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5465 /* If the lhs has been host_associated, is in common, a pointer or is
5466 a target and the function is not using a RESULT variable, aliasing
5467 can occur and a temporary is needed. */
5468 if ((sym->attr.host_assoc
5469 || sym->attr.in_common
5470 || sym->attr.pointer
5471 || sym->attr.cray_pointee
5472 || sym->attr.target)
5473 && expr2->symtree != NULL
5474 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5477 /* A PURE function can unconditionally be called without a temporary. */
5478 if (expr2->value.function.esym != NULL
5479 && expr2->value.function.esym->attr.pure)
5482 /* Implicit_pure functions are those which could legally be declared
5484 if (expr2->value.function.esym != NULL
5485 && expr2->value.function.esym->attr.implicit_pure)
5488 if (!sym->attr.use_assoc
5489 && !sym->attr.in_common
5490 && !sym->attr.pointer
5491 && !sym->attr.target
5492 && !sym->attr.cray_pointee
5493 && expr2->value.function.esym)
5495 /* A temporary is not needed if the function is not contained and
5496 the variable is local or host associated and not a pointer or
5498 if (!expr2->value.function.esym->attr.contained)
5501 /* A temporary is not needed if the lhs has never been host
5502 associated and the procedure is contained. */
5503 else if (!sym->attr.host_assoc)
5506 /* A temporary is not needed if the variable is local and not
5507 a pointer, a target or a result. */
5509 && expr2->value.function.esym->ns == sym->ns->parent)
5513 /* Default to temporary use. */
5518 /* Provide the loop info so that the lhs descriptor can be built for
5519 reallocatable assignments from extrinsic function calls. */
5522 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5525 /* Signal that the function call should not be made by
5526 gfc_conv_loop_setup. */
5527 se->ss->is_alloc_lhs = 1;
5528 gfc_init_loopinfo (loop);
5529 gfc_add_ss_to_loop (loop, *ss);
5530 gfc_add_ss_to_loop (loop, se->ss);
5531 gfc_conv_ss_startstride (loop);
5532 gfc_conv_loop_setup (loop, where);
5533 gfc_copy_loopinfo_to_se (se, loop);
5534 gfc_add_block_to_block (&se->pre, &loop->pre);
5535 gfc_add_block_to_block (&se->pre, &loop->post);
5536 se->ss->is_alloc_lhs = 0;
5540 /* For Assignment to a reallocatable lhs from intrinsic functions,
5541 replace the se.expr (ie. the result) with a temporary descriptor.
5542 Null the data field so that the library allocates space for the
5543 result. Free the data of the original descriptor after the function,
5544 in case it appears in an argument expression and transfer the
5545 result to the original descriptor. */
5548 fcncall_realloc_result (gfc_se *se, int rank)
5556 /* Use the allocation done by the library. Substitute the lhs
5557 descriptor with a copy, whose data field is nulled.*/
5558 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5559 /* Unallocated, the descriptor does not have a dtype. */
5560 tmp = gfc_conv_descriptor_dtype (desc);
5561 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5562 res_desc = gfc_evaluate_now (desc, &se->pre);
5563 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5564 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5566 /* Free the lhs after the function call and copy the result to
5567 the lhs descriptor. */
5568 tmp = gfc_conv_descriptor_data_get (desc);
5569 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5570 gfc_add_expr_to_block (&se->post, tmp);
5571 gfc_add_modify (&se->post, desc, res_desc);
5573 offset = gfc_index_zero_node;
5574 tmp = gfc_index_one_node;
5575 /* Now reset the bounds from zero based to unity based. */
5576 for (n = 0 ; n < rank; n++)
5578 /* Accumulate the offset. */
5579 offset = fold_build2_loc (input_location, MINUS_EXPR,
5580 gfc_array_index_type,
5582 /* Now do the bounds. */
5583 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5584 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5585 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5586 gfc_array_index_type,
5587 tmp, gfc_index_one_node);
5588 gfc_conv_descriptor_lbound_set (&se->post, desc,
5590 gfc_index_one_node);
5591 gfc_conv_descriptor_ubound_set (&se->post, desc,
5592 gfc_rank_cst[n], tmp);
5594 /* The extent for the next contribution to offset. */
5595 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5596 gfc_array_index_type,
5597 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5598 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5599 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5600 gfc_array_index_type,
5601 tmp, gfc_index_one_node);
5603 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5608 /* Try to translate array(:) = func (...), where func is a transformational
5609 array function, without using a temporary. Returns NULL if this isn't the
5613 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5617 gfc_component *comp = NULL;
5620 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5623 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5625 gcc_assert (expr2->value.function.isym
5626 || (gfc_is_proc_ptr_comp (expr2, &comp)
5627 && comp && comp->attr.dimension)
5628 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5629 && expr2->value.function.esym->result->attr.dimension));
5631 ss = gfc_walk_expr (expr1);
5632 gcc_assert (ss != gfc_ss_terminator);
5633 gfc_init_se (&se, NULL);
5634 gfc_start_block (&se.pre);
5635 se.want_pointer = 1;
5637 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5639 if (expr1->ts.type == BT_DERIVED
5640 && expr1->ts.u.derived->attr.alloc_comp)
5643 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5645 gfc_add_expr_to_block (&se.pre, tmp);
5648 se.direct_byref = 1;
5649 se.ss = gfc_walk_expr (expr2);
5650 gcc_assert (se.ss != gfc_ss_terminator);
5652 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5653 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5654 Clearly, this cannot be done for an allocatable function result, since
5655 the shape of the result is unknown and, in any case, the function must
5656 correctly take care of the reallocation internally. For intrinsic
5657 calls, the array data is freed and the library takes care of allocation.
5658 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5660 if (gfc_option.flag_realloc_lhs
5661 && gfc_is_reallocatable_lhs (expr1)
5662 && !gfc_expr_attr (expr1).codimension
5663 && !gfc_is_coindexed (expr1)
5664 && !(expr2->value.function.esym
5665 && expr2->value.function.esym->result->attr.allocatable))
5667 if (!expr2->value.function.isym)
5669 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5670 ss->is_alloc_lhs = 1;
5673 fcncall_realloc_result (&se, expr1->rank);
5676 gfc_conv_function_expr (&se, expr2);
5677 gfc_add_block_to_block (&se.pre, &se.post);
5679 return gfc_finish_block (&se.pre);
5683 /* Try to efficiently translate array(:) = 0. Return NULL if this
5687 gfc_trans_zero_assign (gfc_expr * expr)
5689 tree dest, len, type;
5693 sym = expr->symtree->n.sym;
5694 dest = gfc_get_symbol_decl (sym);
5696 type = TREE_TYPE (dest);
5697 if (POINTER_TYPE_P (type))
5698 type = TREE_TYPE (type);
5699 if (!GFC_ARRAY_TYPE_P (type))
5702 /* Determine the length of the array. */
5703 len = GFC_TYPE_ARRAY_SIZE (type);
5704 if (!len || TREE_CODE (len) != INTEGER_CST)
5707 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5708 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5709 fold_convert (gfc_array_index_type, tmp));
5711 /* If we are zeroing a local array avoid taking its address by emitting
5713 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5714 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5715 dest, build_constructor (TREE_TYPE (dest), NULL));
5717 /* Convert arguments to the correct types. */
5718 dest = fold_convert (pvoid_type_node, dest);
5719 len = fold_convert (size_type_node, len);
5721 /* Construct call to __builtin_memset. */
5722 tmp = build_call_expr_loc (input_location,
5723 built_in_decls[BUILT_IN_MEMSET],
5724 3, dest, integer_zero_node, len);
5725 return fold_convert (void_type_node, tmp);
5729 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5730 that constructs the call to __builtin_memcpy. */
5733 gfc_build_memcpy_call (tree dst, tree src, tree len)
5737 /* Convert arguments to the correct types. */
5738 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5739 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5741 dst = fold_convert (pvoid_type_node, dst);
5743 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5744 src = gfc_build_addr_expr (pvoid_type_node, src);
5746 src = fold_convert (pvoid_type_node, src);
5748 len = fold_convert (size_type_node, len);
5750 /* Construct call to __builtin_memcpy. */
5751 tmp = build_call_expr_loc (input_location,
5752 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5753 return fold_convert (void_type_node, tmp);
5757 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5758 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5759 source/rhs, both are gfc_full_array_ref_p which have been checked for
5763 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5765 tree dst, dlen, dtype;
5766 tree src, slen, stype;
5769 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5770 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5772 dtype = TREE_TYPE (dst);
5773 if (POINTER_TYPE_P (dtype))
5774 dtype = TREE_TYPE (dtype);
5775 stype = TREE_TYPE (src);
5776 if (POINTER_TYPE_P (stype))
5777 stype = TREE_TYPE (stype);
5779 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5782 /* Determine the lengths of the arrays. */
5783 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5784 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5786 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5787 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5788 dlen, fold_convert (gfc_array_index_type, tmp));
5790 slen = GFC_TYPE_ARRAY_SIZE (stype);
5791 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5793 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5794 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5795 slen, fold_convert (gfc_array_index_type, tmp));
5797 /* Sanity check that they are the same. This should always be
5798 the case, as we should already have checked for conformance. */
5799 if (!tree_int_cst_equal (slen, dlen))
5802 return gfc_build_memcpy_call (dst, src, dlen);
5806 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5807 this can't be done. EXPR1 is the destination/lhs for which
5808 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5811 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5813 unsigned HOST_WIDE_INT nelem;
5819 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5823 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5824 dtype = TREE_TYPE (dst);
5825 if (POINTER_TYPE_P (dtype))
5826 dtype = TREE_TYPE (dtype);
5827 if (!GFC_ARRAY_TYPE_P (dtype))
5830 /* Determine the lengths of the array. */
5831 len = GFC_TYPE_ARRAY_SIZE (dtype);
5832 if (!len || TREE_CODE (len) != INTEGER_CST)
5835 /* Confirm that the constructor is the same size. */
5836 if (compare_tree_int (len, nelem) != 0)
5839 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5840 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5841 fold_convert (gfc_array_index_type, tmp));
5843 stype = gfc_typenode_for_spec (&expr2->ts);
5844 src = gfc_build_constant_array_constructor (expr2, stype);
5846 stype = TREE_TYPE (src);
5847 if (POINTER_TYPE_P (stype))
5848 stype = TREE_TYPE (stype);
5850 return gfc_build_memcpy_call (dst, src, len);
5854 /* Tells whether the expression is to be treated as a variable reference. */
5857 expr_is_variable (gfc_expr *expr)
5861 if (expr->expr_type == EXPR_VARIABLE)
5864 arg = gfc_get_noncopying_intrinsic_argument (expr);
5867 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5868 return expr_is_variable (arg);
5875 /* Is the lhs OK for automatic reallocation? */
5878 is_scalar_reallocatable_lhs (gfc_expr *expr)
5882 /* An allocatable variable with no reference. */
5883 if (expr->symtree->n.sym->attr.allocatable
5887 /* All that can be left are allocatable components. */
5888 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5889 && expr->symtree->n.sym->ts.type != BT_CLASS)
5890 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5893 /* Find an allocatable component ref last. */
5894 for (ref = expr->ref; ref; ref = ref->next)
5895 if (ref->type == REF_COMPONENT
5897 && ref->u.c.component->attr.allocatable)
5904 /* Allocate or reallocate scalar lhs, as necessary. */
5907 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5921 if (!expr1 || expr1->rank)
5924 if (!expr2 || expr2->rank)
5927 /* Since this is a scalar lhs, we can afford to do this. That is,
5928 there is no risk of side effects being repeated. */
5929 gfc_init_se (&lse, NULL);
5930 lse.want_pointer = 1;
5931 gfc_conv_expr (&lse, expr1);
5933 jump_label1 = gfc_build_label_decl (NULL_TREE);
5934 jump_label2 = gfc_build_label_decl (NULL_TREE);
5936 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5937 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5938 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5940 tmp = build3_v (COND_EXPR, cond,
5941 build1_v (GOTO_EXPR, jump_label1),
5942 build_empty_stmt (input_location));
5943 gfc_add_expr_to_block (block, tmp);
5945 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5947 /* Use the rhs string length and the lhs element size. */
5948 size = string_length;
5949 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5950 tmp = TYPE_SIZE_UNIT (tmp);
5951 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5952 TREE_TYPE (tmp), tmp,
5953 fold_convert (TREE_TYPE (tmp), size));
5957 /* Otherwise use the length in bytes of the rhs. */
5958 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5959 size_in_bytes = size;
5962 tmp = build_call_expr_loc (input_location,
5963 built_in_decls[BUILT_IN_MALLOC], 1,
5965 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5966 gfc_add_modify (block, lse.expr, tmp);
5967 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5969 /* Deferred characters need checking for lhs and rhs string
5970 length. Other deferred parameter variables will have to
5972 tmp = build1_v (GOTO_EXPR, jump_label2);
5973 gfc_add_expr_to_block (block, tmp);
5975 tmp = build1_v (LABEL_EXPR, jump_label1);
5976 gfc_add_expr_to_block (block, tmp);
5978 /* For a deferred length character, reallocate if lengths of lhs and
5979 rhs are different. */
5980 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5982 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5983 expr1->ts.u.cl->backend_decl, size);
5984 /* Jump past the realloc if the lengths are the same. */
5985 tmp = build3_v (COND_EXPR, cond,
5986 build1_v (GOTO_EXPR, jump_label2),
5987 build_empty_stmt (input_location));
5988 gfc_add_expr_to_block (block, tmp);
5989 tmp = build_call_expr_loc (input_location,
5990 built_in_decls[BUILT_IN_REALLOC], 2,
5991 fold_convert (pvoid_type_node, lse.expr),
5993 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5994 gfc_add_modify (block, lse.expr, tmp);
5995 tmp = build1_v (LABEL_EXPR, jump_label2);
5996 gfc_add_expr_to_block (block, tmp);
5998 /* Update the lhs character length. */
5999 size = string_length;
6000 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6005 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6006 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6007 init_flag indicates initialization expressions and dealloc that no
6008 deallocate prior assignment is needed (if in doubt, set true). */
6011 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6017 gfc_ss *lss_section;
6024 bool scalar_to_array;
6029 /* Assignment of the form lhs = rhs. */
6030 gfc_start_block (&block);
6032 gfc_init_se (&lse, NULL);
6033 gfc_init_se (&rse, NULL);
6036 lss = gfc_walk_expr (expr1);
6037 if (gfc_is_reallocatable_lhs (expr1)
6038 && !(expr2->expr_type == EXPR_FUNCTION
6039 && expr2->value.function.isym != NULL))
6040 lss->is_alloc_lhs = 1;
6042 if (lss != gfc_ss_terminator)
6044 /* Allow the scalarizer to workshare array assignments. */
6045 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6046 ompws_flags |= OMPWS_SCALARIZER_WS;
6048 /* The assignment needs scalarization. */
6051 /* Find a non-scalar SS from the lhs. */
6052 while (lss_section != gfc_ss_terminator
6053 && lss_section->type != GFC_SS_SECTION)
6054 lss_section = lss_section->next;
6056 gcc_assert (lss_section != gfc_ss_terminator);
6058 /* Initialize the scalarizer. */
6059 gfc_init_loopinfo (&loop);
6062 rss = gfc_walk_expr (expr2);
6063 if (rss == gfc_ss_terminator)
6065 /* The rhs is scalar. Add a ss for the expression. */
6066 rss = gfc_get_ss ();
6067 rss->next = gfc_ss_terminator;
6068 rss->type = GFC_SS_SCALAR;
6071 /* Associate the SS with the loop. */
6072 gfc_add_ss_to_loop (&loop, lss);
6073 gfc_add_ss_to_loop (&loop, rss);
6075 /* Calculate the bounds of the scalarization. */
6076 gfc_conv_ss_startstride (&loop);
6077 /* Enable loop reversal. */
6078 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6079 loop.reverse[n] = GFC_ENABLE_REVERSE;
6080 /* Resolve any data dependencies in the statement. */
6081 gfc_conv_resolve_dependencies (&loop, lss, rss);
6082 /* Setup the scalarizing loops. */
6083 gfc_conv_loop_setup (&loop, &expr2->where);
6085 /* Setup the gfc_se structures. */
6086 gfc_copy_loopinfo_to_se (&lse, &loop);
6087 gfc_copy_loopinfo_to_se (&rse, &loop);
6090 gfc_mark_ss_chain_used (rss, 1);
6091 if (loop.temp_ss == NULL)
6094 gfc_mark_ss_chain_used (lss, 1);
6098 lse.ss = loop.temp_ss;
6099 gfc_mark_ss_chain_used (lss, 3);
6100 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6103 /* Start the scalarized loop body. */
6104 gfc_start_scalarized_body (&loop, &body);
6107 gfc_init_block (&body);
6109 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6111 /* Translate the expression. */
6112 gfc_conv_expr (&rse, expr2);
6114 /* Stabilize a string length for temporaries. */
6115 if (expr2->ts.type == BT_CHARACTER)
6116 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6118 string_length = NULL_TREE;
6122 gfc_conv_tmp_array_ref (&lse);
6123 if (expr2->ts.type == BT_CHARACTER)
6124 lse.string_length = string_length;
6127 gfc_conv_expr (&lse, expr1);
6129 /* Assignments of scalar derived types with allocatable components
6130 to arrays must be done with a deep copy and the rhs temporary
6131 must have its components deallocated afterwards. */
6132 scalar_to_array = (expr2->ts.type == BT_DERIVED
6133 && expr2->ts.u.derived->attr.alloc_comp
6134 && !expr_is_variable (expr2)
6135 && !gfc_is_constant_expr (expr2)
6136 && expr1->rank && !expr2->rank);
6137 if (scalar_to_array && dealloc)
6139 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6140 gfc_add_expr_to_block (&loop.post, tmp);
6143 /* For a deferred character length function, the function call must
6144 happen before the (re)allocation of the lhs, otherwise the character
6145 length of the result is not known. */
6146 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6147 || (expr2->expr_type == EXPR_COMPCALL)
6148 || (expr2->expr_type == EXPR_PPC))
6149 && expr2->ts.deferred);
6150 if (gfc_option.flag_realloc_lhs
6151 && expr2->ts.type == BT_CHARACTER
6152 && (def_clen_func || expr2->expr_type == EXPR_OP)
6153 && expr1->ts.deferred)
6154 gfc_add_block_to_block (&block, &rse.pre);
6156 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6157 l_is_temp || init_flag,
6158 expr_is_variable (expr2) || scalar_to_array,
6160 gfc_add_expr_to_block (&body, tmp);
6162 if (lss == gfc_ss_terminator)
6164 /* F2003: Add the code for reallocation on assignment. */
6165 if (gfc_option.flag_realloc_lhs
6166 && is_scalar_reallocatable_lhs (expr1))
6167 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6170 /* Use the scalar assignment as is. */
6171 gfc_add_block_to_block (&block, &body);
6175 gcc_assert (lse.ss == gfc_ss_terminator
6176 && rse.ss == gfc_ss_terminator);
6180 gfc_trans_scalarized_loop_boundary (&loop, &body);
6182 /* We need to copy the temporary to the actual lhs. */
6183 gfc_init_se (&lse, NULL);
6184 gfc_init_se (&rse, NULL);
6185 gfc_copy_loopinfo_to_se (&lse, &loop);
6186 gfc_copy_loopinfo_to_se (&rse, &loop);
6188 rse.ss = loop.temp_ss;
6191 gfc_conv_tmp_array_ref (&rse);
6192 gfc_conv_expr (&lse, expr1);
6194 gcc_assert (lse.ss == gfc_ss_terminator
6195 && rse.ss == gfc_ss_terminator);
6197 if (expr2->ts.type == BT_CHARACTER)
6198 rse.string_length = string_length;
6200 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6201 false, false, dealloc);
6202 gfc_add_expr_to_block (&body, tmp);
6205 /* F2003: Allocate or reallocate lhs of allocatable array. */
6206 if (gfc_option.flag_realloc_lhs
6207 && gfc_is_reallocatable_lhs (expr1)
6208 && !gfc_expr_attr (expr1).codimension
6209 && !gfc_is_coindexed (expr1))
6211 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6212 if (tmp != NULL_TREE)
6213 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6216 /* Generate the copying loops. */
6217 gfc_trans_scalarizing_loops (&loop, &body);
6219 /* Wrap the whole thing up. */
6220 gfc_add_block_to_block (&block, &loop.pre);
6221 gfc_add_block_to_block (&block, &loop.post);
6223 gfc_cleanup_loop (&loop);
6226 return gfc_finish_block (&block);
6230 /* Check whether EXPR is a copyable array. */
6233 copyable_array_p (gfc_expr * expr)
6235 if (expr->expr_type != EXPR_VARIABLE)
6238 /* First check it's an array. */
6239 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6242 if (!gfc_full_array_ref_p (expr->ref, NULL))
6245 /* Next check that it's of a simple enough type. */
6246 switch (expr->ts.type)
6258 return !expr->ts.u.derived->attr.alloc_comp;
6267 /* Translate an assignment. */
6270 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6275 /* Special case a single function returning an array. */
6276 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6278 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6283 /* Special case assigning an array to zero. */
6284 if (copyable_array_p (expr1)
6285 && is_zero_initializer_p (expr2))
6287 tmp = gfc_trans_zero_assign (expr1);
6292 /* Special case copying one array to another. */
6293 if (copyable_array_p (expr1)
6294 && copyable_array_p (expr2)
6295 && gfc_compare_types (&expr1->ts, &expr2->ts)
6296 && !gfc_check_dependency (expr1, expr2, 0))
6298 tmp = gfc_trans_array_copy (expr1, expr2);
6303 /* Special case initializing an array from a constant array constructor. */
6304 if (copyable_array_p (expr1)
6305 && expr2->expr_type == EXPR_ARRAY
6306 && gfc_compare_types (&expr1->ts, &expr2->ts))
6308 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6313 /* Fallback to the scalarizer to generate explicit loops. */
6314 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6318 gfc_trans_init_assign (gfc_code * code)
6320 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6324 gfc_trans_assign (gfc_code * code)
6326 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6330 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6331 A MEMCPY is needed to copy the full data from the default initializer
6332 of the dynamic type. */
6335 gfc_trans_class_init_assign (gfc_code *code)
6339 gfc_se dst,src,memsz;
6340 gfc_expr *lhs,*rhs,*sz;
6342 gfc_start_block (&block);
6344 lhs = gfc_copy_expr (code->expr1);
6345 gfc_add_data_component (lhs);
6347 rhs = gfc_copy_expr (code->expr1);
6348 gfc_add_vptr_component (rhs);
6350 /* Make sure that the component backend_decls have been built, which
6351 will not have happened if the derived types concerned have not
6353 gfc_get_derived_type (rhs->ts.u.derived);
6354 gfc_add_def_init_component (rhs);
6356 sz = gfc_copy_expr (code->expr1);
6357 gfc_add_vptr_component (sz);
6358 gfc_add_size_component (sz);
6360 gfc_init_se (&dst, NULL);
6361 gfc_init_se (&src, NULL);
6362 gfc_init_se (&memsz, NULL);
6363 gfc_conv_expr (&dst, lhs);
6364 gfc_conv_expr (&src, rhs);
6365 gfc_conv_expr (&memsz, sz);
6366 gfc_add_block_to_block (&block, &src.pre);
6367 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6368 gfc_add_expr_to_block (&block, tmp);
6370 return gfc_finish_block (&block);
6374 /* Translate an assignment to a CLASS object
6375 (pointer or ordinary assignment). */
6378 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6385 gfc_start_block (&block);
6387 if (expr2->ts.type != BT_CLASS)
6389 /* Insert an additional assignment which sets the '_vptr' field. */
6390 gfc_symbol *vtab = NULL;
6393 lhs = gfc_copy_expr (expr1);
6394 gfc_add_vptr_component (lhs);
6396 if (expr2->ts.type == BT_DERIVED)
6397 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6398 else if (expr2->expr_type == EXPR_NULL)
6399 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6402 rhs = gfc_get_expr ();
6403 rhs->expr_type = EXPR_VARIABLE;
6404 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6408 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6409 gfc_add_expr_to_block (&block, tmp);
6411 gfc_free_expr (lhs);
6412 gfc_free_expr (rhs);
6415 /* Do the actual CLASS assignment. */
6416 if (expr2->ts.type == BT_CLASS)
6419 gfc_add_data_component (expr1);
6421 if (op == EXEC_ASSIGN)
6422 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6423 else if (op == EXEC_POINTER_ASSIGN)
6424 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6428 gfc_add_expr_to_block (&block, tmp);
6430 return gfc_finish_block (&block);