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 gfc_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));
2252 /* ...and to subexpressions in expr->value. */
2253 switch (expr->expr_type)
2258 case EXPR_SUBSTRING:
2262 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2263 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2267 for (actual = expr->value.function.actual; actual; actual = actual->next)
2268 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2270 if (expr->value.function.esym == NULL
2271 && expr->value.function.isym != NULL
2272 && expr->value.function.actual->expr->symtree
2273 && gfc_map_intrinsic_function (expr, mapping))
2276 for (sym = mapping->syms; sym; sym = sym->next)
2277 if (sym->old == expr->value.function.esym)
2279 expr->value.function.esym = sym->new_sym->n.sym;
2280 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2281 expr->value.function.esym->result = sym->new_sym->n.sym;
2286 case EXPR_STRUCTURE:
2287 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2300 /* Evaluate interface expression EXPR using MAPPING. Store the result
2304 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2305 gfc_se * se, gfc_expr * expr)
2307 expr = gfc_copy_expr (expr);
2308 gfc_apply_interface_mapping_to_expr (mapping, expr);
2309 gfc_conv_expr (se, expr);
2310 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2311 gfc_free_expr (expr);
2315 /* Returns a reference to a temporary array into which a component of
2316 an actual argument derived type array is copied and then returned
2317 after the function call. */
2319 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2320 sym_intent intent, bool formal_ptr)
2338 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2340 gfc_init_se (&lse, NULL);
2341 gfc_init_se (&rse, NULL);
2343 /* Walk the argument expression. */
2344 rss = gfc_walk_expr (expr);
2346 gcc_assert (rss != gfc_ss_terminator);
2348 /* Initialize the scalarizer. */
2349 gfc_init_loopinfo (&loop);
2350 gfc_add_ss_to_loop (&loop, rss);
2352 /* Calculate the bounds of the scalarization. */
2353 gfc_conv_ss_startstride (&loop);
2355 /* Build an ss for the temporary. */
2356 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2357 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2359 base_type = gfc_typenode_for_spec (&expr->ts);
2360 if (GFC_ARRAY_TYPE_P (base_type)
2361 || GFC_DESCRIPTOR_TYPE_P (base_type))
2362 base_type = gfc_get_element_type (base_type);
2364 loop.temp_ss = gfc_get_ss ();;
2365 loop.temp_ss->type = GFC_SS_TEMP;
2366 loop.temp_ss->data.temp.type = base_type;
2368 if (expr->ts.type == BT_CHARACTER)
2369 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2371 loop.temp_ss->string_length = NULL;
2373 parmse->string_length = loop.temp_ss->string_length;
2374 loop.temp_ss->data.temp.dimen = loop.dimen;
2375 loop.temp_ss->next = gfc_ss_terminator;
2377 /* Associate the SS with the loop. */
2378 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2380 /* Setup the scalarizing loops. */
2381 gfc_conv_loop_setup (&loop, &expr->where);
2383 /* Pass the temporary descriptor back to the caller. */
2384 info = &loop.temp_ss->data.info;
2385 parmse->expr = info->descriptor;
2387 /* Setup the gfc_se structures. */
2388 gfc_copy_loopinfo_to_se (&lse, &loop);
2389 gfc_copy_loopinfo_to_se (&rse, &loop);
2392 lse.ss = loop.temp_ss;
2393 gfc_mark_ss_chain_used (rss, 1);
2394 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2396 /* Start the scalarized loop body. */
2397 gfc_start_scalarized_body (&loop, &body);
2399 /* Translate the expression. */
2400 gfc_conv_expr (&rse, expr);
2402 gfc_conv_tmp_array_ref (&lse);
2404 if (intent != INTENT_OUT)
2406 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2407 gfc_add_expr_to_block (&body, tmp);
2408 gcc_assert (rse.ss == gfc_ss_terminator);
2409 gfc_trans_scalarizing_loops (&loop, &body);
2413 /* Make sure that the temporary declaration survives by merging
2414 all the loop declarations into the current context. */
2415 for (n = 0; n < loop.dimen; n++)
2417 gfc_merge_block_scope (&body);
2418 body = loop.code[loop.order[n]];
2420 gfc_merge_block_scope (&body);
2423 /* Add the post block after the second loop, so that any
2424 freeing of allocated memory is done at the right time. */
2425 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2427 /**********Copy the temporary back again.*********/
2429 gfc_init_se (&lse, NULL);
2430 gfc_init_se (&rse, NULL);
2432 /* Walk the argument expression. */
2433 lss = gfc_walk_expr (expr);
2434 rse.ss = loop.temp_ss;
2437 /* Initialize the scalarizer. */
2438 gfc_init_loopinfo (&loop2);
2439 gfc_add_ss_to_loop (&loop2, lss);
2441 /* Calculate the bounds of the scalarization. */
2442 gfc_conv_ss_startstride (&loop2);
2444 /* Setup the scalarizing loops. */
2445 gfc_conv_loop_setup (&loop2, &expr->where);
2447 gfc_copy_loopinfo_to_se (&lse, &loop2);
2448 gfc_copy_loopinfo_to_se (&rse, &loop2);
2450 gfc_mark_ss_chain_used (lss, 1);
2451 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2453 /* Declare the variable to hold the temporary offset and start the
2454 scalarized loop body. */
2455 offset = gfc_create_var (gfc_array_index_type, NULL);
2456 gfc_start_scalarized_body (&loop2, &body);
2458 /* Build the offsets for the temporary from the loop variables. The
2459 temporary array has lbounds of zero and strides of one in all
2460 dimensions, so this is very simple. The offset is only computed
2461 outside the innermost loop, so the overall transfer could be
2462 optimized further. */
2463 info = &rse.ss->data.info;
2464 dimen = info->dimen;
2466 tmp_index = gfc_index_zero_node;
2467 for (n = dimen - 1; n > 0; n--)
2470 tmp = rse.loop->loopvar[n];
2471 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2472 tmp, rse.loop->from[n]);
2473 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2476 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2477 gfc_array_index_type,
2478 rse.loop->to[n-1], rse.loop->from[n-1]);
2479 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2480 gfc_array_index_type,
2481 tmp_str, gfc_index_one_node);
2483 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2484 gfc_array_index_type, tmp, tmp_str);
2487 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2488 gfc_array_index_type,
2489 tmp_index, rse.loop->from[0]);
2490 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2492 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2493 gfc_array_index_type,
2494 rse.loop->loopvar[0], offset);
2496 /* Now use the offset for the reference. */
2497 tmp = build_fold_indirect_ref_loc (input_location,
2499 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2501 if (expr->ts.type == BT_CHARACTER)
2502 rse.string_length = expr->ts.u.cl->backend_decl;
2504 gfc_conv_expr (&lse, expr);
2506 gcc_assert (lse.ss == gfc_ss_terminator);
2508 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2509 gfc_add_expr_to_block (&body, tmp);
2511 /* Generate the copying loops. */
2512 gfc_trans_scalarizing_loops (&loop2, &body);
2514 /* Wrap the whole thing up by adding the second loop to the post-block
2515 and following it by the post-block of the first loop. In this way,
2516 if the temporary needs freeing, it is done after use! */
2517 if (intent != INTENT_IN)
2519 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2520 gfc_add_block_to_block (&parmse->post, &loop2.post);
2523 gfc_add_block_to_block (&parmse->post, &loop.post);
2525 gfc_cleanup_loop (&loop);
2526 gfc_cleanup_loop (&loop2);
2528 /* Pass the string length to the argument expression. */
2529 if (expr->ts.type == BT_CHARACTER)
2530 parmse->string_length = expr->ts.u.cl->backend_decl;
2532 /* Determine the offset for pointer formal arguments and set the
2536 size = gfc_index_one_node;
2537 offset = gfc_index_zero_node;
2538 for (n = 0; n < dimen; n++)
2540 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2542 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2543 gfc_array_index_type, tmp,
2544 gfc_index_one_node);
2545 gfc_conv_descriptor_ubound_set (&parmse->pre,
2549 gfc_conv_descriptor_lbound_set (&parmse->pre,
2552 gfc_index_one_node);
2553 size = gfc_evaluate_now (size, &parmse->pre);
2554 offset = fold_build2_loc (input_location, MINUS_EXPR,
2555 gfc_array_index_type,
2557 offset = gfc_evaluate_now (offset, &parmse->pre);
2558 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2559 gfc_array_index_type,
2560 rse.loop->to[n], rse.loop->from[n]);
2561 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2562 gfc_array_index_type,
2563 tmp, gfc_index_one_node);
2564 size = fold_build2_loc (input_location, MULT_EXPR,
2565 gfc_array_index_type, size, tmp);
2568 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2572 /* We want either the address for the data or the address of the descriptor,
2573 depending on the mode of passing array arguments. */
2575 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2577 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2583 /* Generate the code for argument list functions. */
2586 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2588 /* Pass by value for g77 %VAL(arg), pass the address
2589 indirectly for %LOC, else by reference. Thus %REF
2590 is a "do-nothing" and %LOC is the same as an F95
2592 if (strncmp (name, "%VAL", 4) == 0)
2593 gfc_conv_expr (se, expr);
2594 else if (strncmp (name, "%LOC", 4) == 0)
2596 gfc_conv_expr_reference (se, expr);
2597 se->expr = gfc_build_addr_expr (NULL, se->expr);
2599 else if (strncmp (name, "%REF", 4) == 0)
2600 gfc_conv_expr_reference (se, expr);
2602 gfc_error ("Unknown argument list function at %L", &expr->where);
2606 /* Takes a derived type expression and returns the address of a temporary
2607 class object of the 'declared' type. */
2609 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2610 gfc_typespec class_ts)
2614 gfc_symbol *declared = class_ts.u.derived;
2620 /* The derived type needs to be converted to a temporary
2622 tmp = gfc_typenode_for_spec (&class_ts);
2623 var = gfc_create_var (tmp, "class");
2626 cmp = gfc_find_component (declared, "_vptr", true, true);
2627 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2628 TREE_TYPE (cmp->backend_decl),
2629 var, cmp->backend_decl, NULL_TREE);
2631 /* Remember the vtab corresponds to the derived type
2632 not to the class declared type. */
2633 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2635 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2636 gfc_add_modify (&parmse->pre, ctree,
2637 fold_convert (TREE_TYPE (ctree), tmp));
2639 /* Now set the data field. */
2640 cmp = gfc_find_component (declared, "_data", true, true);
2641 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2642 TREE_TYPE (cmp->backend_decl),
2643 var, cmp->backend_decl, NULL_TREE);
2644 ss = gfc_walk_expr (e);
2645 if (ss == gfc_ss_terminator)
2648 gfc_conv_expr_reference (parmse, e);
2649 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2650 gfc_add_modify (&parmse->pre, ctree, tmp);
2655 gfc_conv_expr (parmse, e);
2656 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2659 /* Pass the address of the class object. */
2660 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2664 /* The following routine generates code for the intrinsic
2665 procedures from the ISO_C_BINDING module:
2667 * C_FUNLOC (function)
2668 * C_F_POINTER (subroutine)
2669 * C_F_PROCPOINTER (subroutine)
2670 * C_ASSOCIATED (function)
2671 One exception which is not handled here is C_F_POINTER with non-scalar
2672 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2675 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2676 gfc_actual_arglist * arg)
2681 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2683 if (arg->expr->rank == 0)
2684 gfc_conv_expr_reference (se, arg->expr);
2688 /* This is really the actual arg because no formal arglist is
2689 created for C_LOC. */
2690 fsym = arg->expr->symtree->n.sym;
2692 /* We should want it to do g77 calling convention. */
2694 && !(fsym->attr.pointer || fsym->attr.allocatable)
2695 && fsym->as->type != AS_ASSUMED_SHAPE;
2696 f = f || !sym->attr.always_explicit;
2698 argss = gfc_walk_expr (arg->expr);
2699 gfc_conv_array_parameter (se, arg->expr, argss, f,
2703 /* TODO -- the following two lines shouldn't be necessary, but if
2704 they're removed, a bug is exposed later in the code path.
2705 This workaround was thus introduced, but will have to be
2706 removed; please see PR 35150 for details about the issue. */
2707 se->expr = convert (pvoid_type_node, se->expr);
2708 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2712 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2714 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2715 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2716 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2717 gfc_conv_expr_reference (se, arg->expr);
2721 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2722 && arg->next->expr->rank == 0)
2723 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2725 /* Convert c_f_pointer if fptr is a scalar
2726 and convert c_f_procpointer. */
2730 gfc_init_se (&cptrse, NULL);
2731 gfc_conv_expr (&cptrse, arg->expr);
2732 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2733 gfc_add_block_to_block (&se->post, &cptrse.post);
2735 gfc_init_se (&fptrse, NULL);
2736 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2737 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2738 fptrse.want_pointer = 1;
2740 gfc_conv_expr (&fptrse, arg->next->expr);
2741 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2742 gfc_add_block_to_block (&se->post, &fptrse.post);
2744 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2745 && arg->next->expr->symtree->n.sym->attr.dummy)
2746 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2749 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2750 TREE_TYPE (fptrse.expr),
2752 fold_convert (TREE_TYPE (fptrse.expr),
2757 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2762 /* Build the addr_expr for the first argument. The argument is
2763 already an *address* so we don't need to set want_pointer in
2765 gfc_init_se (&arg1se, NULL);
2766 gfc_conv_expr (&arg1se, arg->expr);
2767 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2768 gfc_add_block_to_block (&se->post, &arg1se.post);
2770 /* See if we were given two arguments. */
2771 if (arg->next == NULL)
2772 /* Only given one arg so generate a null and do a
2773 not-equal comparison against the first arg. */
2774 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2776 fold_convert (TREE_TYPE (arg1se.expr),
2777 null_pointer_node));
2783 /* Given two arguments so build the arg2se from second arg. */
2784 gfc_init_se (&arg2se, NULL);
2785 gfc_conv_expr (&arg2se, arg->next->expr);
2786 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2787 gfc_add_block_to_block (&se->post, &arg2se.post);
2789 /* Generate test to compare that the two args are equal. */
2790 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2791 arg1se.expr, arg2se.expr);
2792 /* Generate test to ensure that the first arg is not null. */
2793 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2795 arg1se.expr, null_pointer_node);
2797 /* Finally, the generated test must check that both arg1 is not
2798 NULL and that it is equal to the second arg. */
2799 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2801 not_null_expr, eq_expr);
2807 /* Nothing was done. */
2811 /* Generate code for a procedure call. Note can return se->post != NULL.
2812 If se->direct_byref is set then se->expr contains the return parameter.
2813 Return nonzero, if the call has alternate specifiers.
2814 'expr' is only needed for procedure pointer components. */
2817 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2818 gfc_actual_arglist * args, gfc_expr * expr,
2819 VEC(tree,gc) *append_args)
2821 gfc_interface_mapping mapping;
2822 VEC(tree,gc) *arglist;
2823 VEC(tree,gc) *retargs;
2834 VEC(tree,gc) *stringargs;
2836 gfc_formal_arglist *formal;
2837 gfc_actual_arglist *arg;
2838 int has_alternate_specifier = 0;
2839 bool need_interface_mapping;
2846 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2847 gfc_component *comp = NULL;
2857 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2858 && conv_isocbinding_procedure (se, sym, args))
2861 gfc_is_proc_ptr_comp (expr, &comp);
2865 if (!sym->attr.elemental)
2867 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2868 if (se->ss->useflags)
2870 gcc_assert ((!comp && gfc_return_by_reference (sym)
2871 && sym->result->attr.dimension)
2872 || (comp && comp->attr.dimension));
2873 gcc_assert (se->loop != NULL);
2875 /* Access the previously obtained result. */
2876 gfc_conv_tmp_array_ref (se);
2880 info = &se->ss->data.info;
2885 gfc_init_block (&post);
2886 gfc_init_interface_mapping (&mapping);
2889 formal = sym->formal;
2890 need_interface_mapping = sym->attr.dimension ||
2891 (sym->ts.type == BT_CHARACTER
2892 && sym->ts.u.cl->length
2893 && sym->ts.u.cl->length->expr_type
2898 formal = comp->formal;
2899 need_interface_mapping = comp->attr.dimension ||
2900 (comp->ts.type == BT_CHARACTER
2901 && comp->ts.u.cl->length
2902 && comp->ts.u.cl->length->expr_type
2906 /* Evaluate the arguments. */
2907 for (arg = args; arg != NULL;
2908 arg = arg->next, formal = formal ? formal->next : NULL)
2911 fsym = formal ? formal->sym : NULL;
2912 parm_kind = MISSING;
2916 if (se->ignore_optional)
2918 /* Some intrinsics have already been resolved to the correct
2922 else if (arg->label)
2924 has_alternate_specifier = 1;
2929 /* Pass a NULL pointer for an absent arg. */
2930 gfc_init_se (&parmse, NULL);
2931 parmse.expr = null_pointer_node;
2932 if (arg->missing_arg_type == BT_CHARACTER)
2933 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2936 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2938 /* Pass a NULL pointer to denote an absent arg. */
2939 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2940 gfc_init_se (&parmse, NULL);
2941 parmse.expr = null_pointer_node;
2942 if (arg->missing_arg_type == BT_CHARACTER)
2943 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2945 else if (fsym && fsym->ts.type == BT_CLASS
2946 && e->ts.type == BT_DERIVED)
2948 /* The derived type needs to be converted to a temporary
2950 gfc_init_se (&parmse, se);
2951 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2953 else if (se->ss && se->ss->useflags)
2955 /* An elemental function inside a scalarized loop. */
2956 gfc_init_se (&parmse, se);
2957 gfc_conv_expr_reference (&parmse, e);
2958 parm_kind = ELEMENTAL;
2962 /* A scalar or transformational function. */
2963 gfc_init_se (&parmse, NULL);
2964 argss = gfc_walk_expr (e);
2966 if (argss == gfc_ss_terminator)
2968 if (e->expr_type == EXPR_VARIABLE
2969 && e->symtree->n.sym->attr.cray_pointee
2970 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2972 /* The Cray pointer needs to be converted to a pointer to
2973 a type given by the expression. */
2974 gfc_conv_expr (&parmse, e);
2975 type = build_pointer_type (TREE_TYPE (parmse.expr));
2976 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2977 parmse.expr = convert (type, tmp);
2979 else if (fsym && fsym->attr.value)
2981 if (fsym->ts.type == BT_CHARACTER
2982 && fsym->ts.is_c_interop
2983 && fsym->ns->proc_name != NULL
2984 && fsym->ns->proc_name->attr.is_bind_c)
2987 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2988 if (parmse.expr == NULL)
2989 gfc_conv_expr (&parmse, e);
2992 gfc_conv_expr (&parmse, e);
2994 else if (arg->name && arg->name[0] == '%')
2995 /* Argument list functions %VAL, %LOC and %REF are signalled
2996 through arg->name. */
2997 conv_arglist_function (&parmse, arg->expr, arg->name);
2998 else if ((e->expr_type == EXPR_FUNCTION)
2999 && ((e->value.function.esym
3000 && e->value.function.esym->result->attr.pointer)
3001 || (!e->value.function.esym
3002 && e->symtree->n.sym->attr.pointer))
3003 && fsym && fsym->attr.target)
3005 gfc_conv_expr (&parmse, e);
3006 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3008 else if (e->expr_type == EXPR_FUNCTION
3009 && e->symtree->n.sym->result
3010 && e->symtree->n.sym->result != e->symtree->n.sym
3011 && e->symtree->n.sym->result->attr.proc_pointer)
3013 /* Functions returning procedure pointers. */
3014 gfc_conv_expr (&parmse, e);
3015 if (fsym && fsym->attr.proc_pointer)
3016 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3020 gfc_conv_expr_reference (&parmse, e);
3022 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3023 allocated on entry, it must be deallocated. */
3024 if (fsym && fsym->attr.allocatable
3025 && fsym->attr.intent == INTENT_OUT)
3029 gfc_init_block (&block);
3030 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3032 gfc_add_expr_to_block (&block, tmp);
3033 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3034 void_type_node, parmse.expr,
3036 gfc_add_expr_to_block (&block, tmp);
3038 if (fsym->attr.optional
3039 && e->expr_type == EXPR_VARIABLE
3040 && e->symtree->n.sym->attr.optional)
3042 tmp = fold_build3_loc (input_location, COND_EXPR,
3044 gfc_conv_expr_present (e->symtree->n.sym),
3045 gfc_finish_block (&block),
3046 build_empty_stmt (input_location));
3049 tmp = gfc_finish_block (&block);
3051 gfc_add_expr_to_block (&se->pre, tmp);
3054 if (fsym && e->expr_type != EXPR_NULL
3055 && ((fsym->attr.pointer
3056 && fsym->attr.flavor != FL_PROCEDURE)
3057 || (fsym->attr.proc_pointer
3058 && !(e->expr_type == EXPR_VARIABLE
3059 && e->symtree->n.sym->attr.dummy))
3060 || (fsym->attr.proc_pointer
3061 && e->expr_type == EXPR_VARIABLE
3062 && gfc_is_proc_ptr_comp (e, NULL))
3063 || fsym->attr.allocatable))
3065 /* Scalar pointer dummy args require an extra level of
3066 indirection. The null pointer already contains
3067 this level of indirection. */
3068 parm_kind = SCALAR_POINTER;
3069 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3075 /* If the procedure requires an explicit interface, the actual
3076 argument is passed according to the corresponding formal
3077 argument. If the corresponding formal argument is a POINTER,
3078 ALLOCATABLE or assumed shape, we do not use g77's calling
3079 convention, and pass the address of the array descriptor
3080 instead. Otherwise we use g77's calling convention. */
3083 && !(fsym->attr.pointer || fsym->attr.allocatable)
3084 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3086 f = f || !comp->attr.always_explicit;
3088 f = f || !sym->attr.always_explicit;
3090 /* If the argument is a function call that may not create
3091 a temporary for the result, we have to check that we
3092 can do it, i.e. that there is no alias between this
3093 argument and another one. */
3094 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3100 intent = fsym->attr.intent;
3102 intent = INTENT_UNKNOWN;
3104 if (gfc_check_fncall_dependency (e, intent, sym, args,
3106 parmse.force_tmp = 1;
3108 iarg = e->value.function.actual->expr;
3110 /* Temporary needed if aliasing due to host association. */
3111 if (sym->attr.contained
3113 && !sym->attr.implicit_pure
3114 && !sym->attr.use_assoc
3115 && iarg->expr_type == EXPR_VARIABLE
3116 && sym->ns == iarg->symtree->n.sym->ns)
3117 parmse.force_tmp = 1;
3119 /* Ditto within module. */
3120 if (sym->attr.use_assoc
3122 && !sym->attr.implicit_pure
3123 && iarg->expr_type == EXPR_VARIABLE
3124 && sym->module == iarg->symtree->n.sym->module)
3125 parmse.force_tmp = 1;
3128 if (e->expr_type == EXPR_VARIABLE
3129 && is_subref_array (e))
3130 /* The actual argument is a component reference to an
3131 array of derived types. In this case, the argument
3132 is converted to a temporary, which is passed and then
3133 written back after the procedure call. */
3134 gfc_conv_subref_array_arg (&parmse, e, f,
3135 fsym ? fsym->attr.intent : INTENT_INOUT,
3136 fsym && fsym->attr.pointer);
3138 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3141 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3142 allocated on entry, it must be deallocated. */
3143 if (fsym && fsym->attr.allocatable
3144 && fsym->attr.intent == INTENT_OUT)
3146 tmp = build_fold_indirect_ref_loc (input_location,
3148 tmp = gfc_trans_dealloc_allocated (tmp);
3149 if (fsym->attr.optional
3150 && e->expr_type == EXPR_VARIABLE
3151 && e->symtree->n.sym->attr.optional)
3152 tmp = fold_build3_loc (input_location, COND_EXPR,
3154 gfc_conv_expr_present (e->symtree->n.sym),
3155 tmp, build_empty_stmt (input_location));
3156 gfc_add_expr_to_block (&se->pre, tmp);
3161 /* The case with fsym->attr.optional is that of a user subroutine
3162 with an interface indicating an optional argument. When we call
3163 an intrinsic subroutine, however, fsym is NULL, but we might still
3164 have an optional argument, so we proceed to the substitution
3166 if (e && (fsym == NULL || fsym->attr.optional))
3168 /* If an optional argument is itself an optional dummy argument,
3169 check its presence and substitute a null if absent. This is
3170 only needed when passing an array to an elemental procedure
3171 as then array elements are accessed - or no NULL pointer is
3172 allowed and a "1" or "0" should be passed if not present.
3173 When passing a non-array-descriptor full array to a
3174 non-array-descriptor dummy, no check is needed. For
3175 array-descriptor actual to array-descriptor dummy, see
3176 PR 41911 for why a check has to be inserted.
3177 fsym == NULL is checked as intrinsics required the descriptor
3178 but do not always set fsym. */
3179 if (e->expr_type == EXPR_VARIABLE
3180 && e->symtree->n.sym->attr.optional
3181 && ((e->rank > 0 && sym->attr.elemental)
3182 || e->representation.length || e->ts.type == BT_CHARACTER
3186 && (fsym->as->type == AS_ASSUMED_SHAPE
3187 || fsym->as->type == AS_DEFERRED))))))
3188 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3189 e->representation.length);
3194 /* Obtain the character length of an assumed character length
3195 length procedure from the typespec. */
3196 if (fsym->ts.type == BT_CHARACTER
3197 && parmse.string_length == NULL_TREE
3198 && e->ts.type == BT_PROCEDURE
3199 && e->symtree->n.sym->ts.type == BT_CHARACTER
3200 && e->symtree->n.sym->ts.u.cl->length != NULL
3201 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3203 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3204 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3208 if (fsym && need_interface_mapping && e)
3209 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3211 gfc_add_block_to_block (&se->pre, &parmse.pre);
3212 gfc_add_block_to_block (&post, &parmse.post);
3214 /* Allocated allocatable components of derived types must be
3215 deallocated for non-variable scalars. Non-variable arrays are
3216 dealt with in trans-array.c(gfc_conv_array_parameter). */
3217 if (e && e->ts.type == BT_DERIVED
3218 && e->ts.u.derived->attr.alloc_comp
3219 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3220 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3223 tmp = build_fold_indirect_ref_loc (input_location,
3225 parm_rank = e->rank;
3233 case (SCALAR_POINTER):
3234 tmp = build_fold_indirect_ref_loc (input_location,
3239 if (e->expr_type == EXPR_OP
3240 && e->value.op.op == INTRINSIC_PARENTHESES
3241 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3244 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3245 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3246 gfc_add_expr_to_block (&se->post, local_tmp);
3249 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3251 gfc_add_expr_to_block (&se->post, tmp);
3254 /* Add argument checking of passing an unallocated/NULL actual to
3255 a nonallocatable/nonpointer dummy. */
3257 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3259 symbol_attribute attr;
3263 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3264 attr = gfc_expr_attr (e);
3266 goto end_pointer_check;
3270 /* If the actual argument is an optional pointer/allocatable and
3271 the formal argument takes an nonpointer optional value,
3272 it is invalid to pass a non-present argument on, even
3273 though there is no technical reason for this in gfortran.
3274 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3275 tree present, null_ptr, type;
3277 if (attr.allocatable
3278 && (fsym == NULL || !fsym->attr.allocatable))
3279 asprintf (&msg, "Allocatable actual argument '%s' is not "
3280 "allocated or not present", e->symtree->n.sym->name);
3281 else if (attr.pointer
3282 && (fsym == NULL || !fsym->attr.pointer))
3283 asprintf (&msg, "Pointer actual argument '%s' is not "
3284 "associated or not present",
3285 e->symtree->n.sym->name);
3286 else if (attr.proc_pointer
3287 && (fsym == NULL || !fsym->attr.proc_pointer))
3288 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3289 "associated or not present",
3290 e->symtree->n.sym->name);
3292 goto end_pointer_check;
3294 present = gfc_conv_expr_present (e->symtree->n.sym);
3295 type = TREE_TYPE (present);
3296 present = fold_build2_loc (input_location, EQ_EXPR,
3297 boolean_type_node, present,
3299 null_pointer_node));
3300 type = TREE_TYPE (parmse.expr);
3301 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3302 boolean_type_node, parmse.expr,
3304 null_pointer_node));
3305 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3306 boolean_type_node, present, null_ptr);
3310 if (attr.allocatable
3311 && (fsym == NULL || !fsym->attr.allocatable))
3312 asprintf (&msg, "Allocatable actual argument '%s' is not "
3313 "allocated", e->symtree->n.sym->name);
3314 else if (attr.pointer
3315 && (fsym == NULL || !fsym->attr.pointer))
3316 asprintf (&msg, "Pointer actual argument '%s' is not "
3317 "associated", e->symtree->n.sym->name);
3318 else if (attr.proc_pointer
3319 && (fsym == NULL || !fsym->attr.proc_pointer))
3320 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3321 "associated", e->symtree->n.sym->name);
3323 goto end_pointer_check;
3326 cond = fold_build2_loc (input_location, EQ_EXPR,
3327 boolean_type_node, parmse.expr,
3328 fold_convert (TREE_TYPE (parmse.expr),
3329 null_pointer_node));
3332 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3338 /* Deferred length dummies pass the character length by reference
3339 so that the value can be returned. */
3340 if (parmse.string_length && fsym && fsym->ts.deferred)
3342 tmp = parmse.string_length;
3343 if (TREE_CODE (tmp) != VAR_DECL)
3344 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3345 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3348 /* Character strings are passed as two parameters, a length and a
3349 pointer - except for Bind(c) which only passes the pointer. */
3350 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3351 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3353 VEC_safe_push (tree, gc, arglist, parmse.expr);
3355 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3362 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3363 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3364 else if (ts.type == BT_CHARACTER)
3366 if (ts.u.cl->length == NULL)
3368 /* Assumed character length results are not allowed by 5.1.1.5 of the
3369 standard and are trapped in resolve.c; except in the case of SPREAD
3370 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3371 we take the character length of the first argument for the result.
3372 For dummies, we have to look through the formal argument list for
3373 this function and use the character length found there.*/
3374 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3375 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3376 else if (!sym->attr.dummy)
3377 cl.backend_decl = VEC_index (tree, stringargs, 0);
3380 formal = sym->ns->proc_name->formal;
3381 for (; formal; formal = formal->next)
3382 if (strcmp (formal->sym->name, sym->name) == 0)
3383 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3390 /* Calculate the length of the returned string. */
3391 gfc_init_se (&parmse, NULL);
3392 if (need_interface_mapping)
3393 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3395 gfc_conv_expr (&parmse, ts.u.cl->length);
3396 gfc_add_block_to_block (&se->pre, &parmse.pre);
3397 gfc_add_block_to_block (&se->post, &parmse.post);
3399 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3400 tmp = fold_build2_loc (input_location, MAX_EXPR,
3401 gfc_charlen_type_node, tmp,
3402 build_int_cst (gfc_charlen_type_node, 0));
3403 cl.backend_decl = tmp;
3406 /* Set up a charlen structure for it. */
3411 len = cl.backend_decl;
3414 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3415 || (!comp && gfc_return_by_reference (sym));
3418 if (se->direct_byref)
3420 /* Sometimes, too much indirection can be applied; e.g. for
3421 function_result = array_valued_recursive_function. */
3422 if (TREE_TYPE (TREE_TYPE (se->expr))
3423 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3424 && GFC_DESCRIPTOR_TYPE_P
3425 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3426 se->expr = build_fold_indirect_ref_loc (input_location,
3429 /* If the lhs of an assignment x = f(..) is allocatable and
3430 f2003 is allowed, we must do the automatic reallocation.
3431 TODO - deal with intrinsics, without using a temporary. */
3432 if (gfc_option.flag_realloc_lhs
3433 && se->ss && se->ss->loop_chain
3434 && se->ss->loop_chain->is_alloc_lhs
3435 && !expr->value.function.isym
3436 && sym->result->as != NULL)
3438 /* Evaluate the bounds of the result, if known. */
3439 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3442 /* Perform the automatic reallocation. */
3443 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3445 gfc_add_expr_to_block (&se->pre, tmp);
3447 /* Pass the temporary as the first argument. */
3448 result = info->descriptor;
3451 result = build_fold_indirect_ref_loc (input_location,
3453 VEC_safe_push (tree, gc, retargs, se->expr);
3455 else if (comp && comp->attr.dimension)
3457 gcc_assert (se->loop && info);
3459 /* Set the type of the array. */
3460 tmp = gfc_typenode_for_spec (&comp->ts);
3461 info->dimen = se->loop->dimen;
3463 /* Evaluate the bounds of the result, if known. */
3464 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3466 /* If the lhs of an assignment x = f(..) is allocatable and
3467 f2003 is allowed, we must not generate the function call
3468 here but should just send back the results of the mapping.
3469 This is signalled by the function ss being flagged. */
3470 if (gfc_option.flag_realloc_lhs
3471 && se->ss && se->ss->is_alloc_lhs)
3473 gfc_free_interface_mapping (&mapping);
3474 return has_alternate_specifier;
3477 /* Create a temporary to store the result. In case the function
3478 returns a pointer, the temporary will be a shallow copy and
3479 mustn't be deallocated. */
3480 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3481 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3482 NULL_TREE, false, !comp->attr.pointer,
3483 callee_alloc, &se->ss->expr->where);
3485 /* Pass the temporary as the first argument. */
3486 result = info->descriptor;
3487 tmp = gfc_build_addr_expr (NULL_TREE, result);
3488 VEC_safe_push (tree, gc, retargs, tmp);
3490 else if (!comp && sym->result->attr.dimension)
3492 gcc_assert (se->loop && info);
3494 /* Set the type of the array. */
3495 tmp = gfc_typenode_for_spec (&ts);
3496 info->dimen = se->loop->dimen;
3498 /* Evaluate the bounds of the result, if known. */
3499 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3501 /* If the lhs of an assignment x = f(..) is allocatable and
3502 f2003 is allowed, we must not generate the function call
3503 here but should just send back the results of the mapping.
3504 This is signalled by the function ss being flagged. */
3505 if (gfc_option.flag_realloc_lhs
3506 && se->ss && se->ss->is_alloc_lhs)
3508 gfc_free_interface_mapping (&mapping);
3509 return has_alternate_specifier;
3512 /* Create a temporary to store the result. In case the function
3513 returns a pointer, the temporary will be a shallow copy and
3514 mustn't be deallocated. */
3515 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3516 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3517 NULL_TREE, false, !sym->attr.pointer,
3518 callee_alloc, &se->ss->expr->where);
3520 /* Pass the temporary as the first argument. */
3521 result = info->descriptor;
3522 tmp = gfc_build_addr_expr (NULL_TREE, result);
3523 VEC_safe_push (tree, gc, retargs, tmp);
3525 else if (ts.type == BT_CHARACTER)
3527 /* Pass the string length. */
3528 type = gfc_get_character_type (ts.kind, ts.u.cl);
3529 type = build_pointer_type (type);
3531 /* Return an address to a char[0:len-1]* temporary for
3532 character pointers. */
3533 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3534 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3536 var = gfc_create_var (type, "pstr");
3538 if ((!comp && sym->attr.allocatable)
3539 || (comp && comp->attr.allocatable))
3540 gfc_add_modify (&se->pre, var,
3541 fold_convert (TREE_TYPE (var),
3542 null_pointer_node));
3544 /* Provide an address expression for the function arguments. */
3545 var = gfc_build_addr_expr (NULL_TREE, var);
3548 var = gfc_conv_string_tmp (se, type, len);
3550 VEC_safe_push (tree, gc, retargs, var);
3554 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3556 type = gfc_get_complex_type (ts.kind);
3557 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3558 VEC_safe_push (tree, gc, retargs, var);
3561 if (ts.type == BT_CHARACTER && ts.deferred
3562 && (sym->attr.allocatable || sym->attr.pointer))
3565 if (TREE_CODE (tmp) != VAR_DECL)
3566 tmp = gfc_evaluate_now (len, &se->pre);
3567 len = gfc_build_addr_expr (NULL_TREE, tmp);
3570 /* Add the string length to the argument list. */
3571 if (ts.type == BT_CHARACTER)
3572 VEC_safe_push (tree, gc, retargs, len);
3574 gfc_free_interface_mapping (&mapping);
3576 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3577 arglen = (VEC_length (tree, arglist)
3578 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3579 VEC_reserve_exact (tree, gc, retargs, arglen);
3581 /* Add the return arguments. */
3582 VEC_splice (tree, retargs, arglist);
3584 /* Add the hidden string length parameters to the arguments. */
3585 VEC_splice (tree, retargs, stringargs);
3587 /* We may want to append extra arguments here. This is used e.g. for
3588 calls to libgfortran_matmul_??, which need extra information. */
3589 if (!VEC_empty (tree, append_args))
3590 VEC_splice (tree, retargs, append_args);
3593 /* Generate the actual call. */
3594 conv_function_val (se, sym, expr);
3596 /* If there are alternate return labels, function type should be
3597 integer. Can't modify the type in place though, since it can be shared
3598 with other functions. For dummy arguments, the typing is done to
3599 to this result, even if it has to be repeated for each call. */
3600 if (has_alternate_specifier
3601 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3603 if (!sym->attr.dummy)
3605 TREE_TYPE (sym->backend_decl)
3606 = build_function_type (integer_type_node,
3607 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3608 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3611 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3614 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3615 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3617 /* If we have a pointer function, but we don't want a pointer, e.g.
3620 where f is pointer valued, we have to dereference the result. */
3621 if (!se->want_pointer && !byref
3622 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3623 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3624 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3626 /* f2c calling conventions require a scalar default real function to
3627 return a double precision result. Convert this back to default
3628 real. We only care about the cases that can happen in Fortran 77.
3630 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3631 && sym->ts.kind == gfc_default_real_kind
3632 && !sym->attr.always_explicit)
3633 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3635 /* A pure function may still have side-effects - it may modify its
3637 TREE_SIDE_EFFECTS (se->expr) = 1;
3639 if (!sym->attr.pure)
3640 TREE_SIDE_EFFECTS (se->expr) = 1;
3645 /* Add the function call to the pre chain. There is no expression. */
3646 gfc_add_expr_to_block (&se->pre, se->expr);
3647 se->expr = NULL_TREE;
3649 if (!se->direct_byref)
3651 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3653 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3655 /* Check the data pointer hasn't been modified. This would
3656 happen in a function returning a pointer. */
3657 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3658 tmp = fold_build2_loc (input_location, NE_EXPR,
3661 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3664 se->expr = info->descriptor;
3665 /* Bundle in the string length. */
3666 se->string_length = len;
3668 else if (ts.type == BT_CHARACTER)
3670 /* Dereference for character pointer results. */
3671 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3672 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3673 se->expr = build_fold_indirect_ref_loc (input_location, var);
3678 se->string_length = len;
3679 else if (sym->attr.allocatable || sym->attr.pointer)
3680 se->string_length = cl.backend_decl;
3684 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3685 se->expr = build_fold_indirect_ref_loc (input_location, var);
3690 /* Follow the function call with the argument post block. */
3693 gfc_add_block_to_block (&se->pre, &post);
3695 /* Transformational functions of derived types with allocatable
3696 components must have the result allocatable components copied. */
3697 arg = expr->value.function.actual;
3698 if (result && arg && expr->rank
3699 && expr->value.function.isym
3700 && expr->value.function.isym->transformational
3701 && arg->expr->ts.type == BT_DERIVED
3702 && arg->expr->ts.u.derived->attr.alloc_comp)
3705 /* Copy the allocatable components. We have to use a
3706 temporary here to prevent source allocatable components
3707 from being corrupted. */
3708 tmp2 = gfc_evaluate_now (result, &se->pre);
3709 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3710 result, tmp2, expr->rank);
3711 gfc_add_expr_to_block (&se->pre, tmp);
3712 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3714 gfc_add_expr_to_block (&se->pre, tmp);
3716 /* Finally free the temporary's data field. */
3717 tmp = gfc_conv_descriptor_data_get (tmp2);
3718 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3719 gfc_add_expr_to_block (&se->pre, tmp);
3723 gfc_add_block_to_block (&se->post, &post);
3725 return has_alternate_specifier;
3729 /* Fill a character string with spaces. */
3732 fill_with_spaces (tree start, tree type, tree size)
3734 stmtblock_t block, loop;
3735 tree i, el, exit_label, cond, tmp;
3737 /* For a simple char type, we can call memset(). */
3738 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3739 return build_call_expr_loc (input_location,
3740 built_in_decls[BUILT_IN_MEMSET], 3, start,
3741 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3742 lang_hooks.to_target_charset (' ')),
3745 /* Otherwise, we use a loop:
3746 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3750 /* Initialize variables. */
3751 gfc_init_block (&block);
3752 i = gfc_create_var (sizetype, "i");
3753 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3754 el = gfc_create_var (build_pointer_type (type), "el");
3755 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3756 exit_label = gfc_build_label_decl (NULL_TREE);
3757 TREE_USED (exit_label) = 1;
3761 gfc_init_block (&loop);
3763 /* Exit condition. */
3764 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3765 build_zero_cst (sizetype));
3766 tmp = build1_v (GOTO_EXPR, exit_label);
3767 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3768 build_empty_stmt (input_location));
3769 gfc_add_expr_to_block (&loop, tmp);
3772 gfc_add_modify (&loop,
3773 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3774 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3776 /* Increment loop variables. */
3777 gfc_add_modify (&loop, i,
3778 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3779 TYPE_SIZE_UNIT (type)));
3780 gfc_add_modify (&loop, el,
3781 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3782 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3784 /* Making the loop... actually loop! */
3785 tmp = gfc_finish_block (&loop);
3786 tmp = build1_v (LOOP_EXPR, tmp);
3787 gfc_add_expr_to_block (&block, tmp);
3789 /* The exit label. */
3790 tmp = build1_v (LABEL_EXPR, exit_label);
3791 gfc_add_expr_to_block (&block, tmp);
3794 return gfc_finish_block (&block);
3798 /* Generate code to copy a string. */
3801 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3802 int dkind, tree slength, tree src, int skind)
3804 tree tmp, dlen, slen;
3813 stmtblock_t tempblock;
3815 gcc_assert (dkind == skind);
3817 if (slength != NULL_TREE)
3819 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3820 ssc = gfc_string_to_single_character (slen, src, skind);
3824 slen = build_int_cst (size_type_node, 1);
3828 if (dlength != NULL_TREE)
3830 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3831 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3835 dlen = build_int_cst (size_type_node, 1);
3839 /* Assign directly if the types are compatible. */
3840 if (dsc != NULL_TREE && ssc != NULL_TREE
3841 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3843 gfc_add_modify (block, dsc, ssc);
3847 /* Do nothing if the destination length is zero. */
3848 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3849 build_int_cst (size_type_node, 0));
3851 /* The following code was previously in _gfortran_copy_string:
3853 // The two strings may overlap so we use memmove.
3855 copy_string (GFC_INTEGER_4 destlen, char * dest,
3856 GFC_INTEGER_4 srclen, const char * src)
3858 if (srclen >= destlen)
3860 // This will truncate if too long.
3861 memmove (dest, src, destlen);
3865 memmove (dest, src, srclen);
3867 memset (&dest[srclen], ' ', destlen - srclen);
3871 We're now doing it here for better optimization, but the logic
3874 /* For non-default character kinds, we have to multiply the string
3875 length by the base type size. */
3876 chartype = gfc_get_char_type (dkind);
3877 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3878 fold_convert (size_type_node, slen),
3879 fold_convert (size_type_node,
3880 TYPE_SIZE_UNIT (chartype)));
3881 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3882 fold_convert (size_type_node, dlen),
3883 fold_convert (size_type_node,
3884 TYPE_SIZE_UNIT (chartype)));
3886 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3887 dest = fold_convert (pvoid_type_node, dest);
3889 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3891 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3892 src = fold_convert (pvoid_type_node, src);
3894 src = gfc_build_addr_expr (pvoid_type_node, src);
3896 /* Truncate string if source is too long. */
3897 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3899 tmp2 = build_call_expr_loc (input_location,
3900 built_in_decls[BUILT_IN_MEMMOVE],
3901 3, dest, src, dlen);
3903 /* Else copy and pad with spaces. */
3904 tmp3 = build_call_expr_loc (input_location,
3905 built_in_decls[BUILT_IN_MEMMOVE],
3906 3, dest, src, slen);
3908 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3909 dest, fold_convert (sizetype, slen));
3910 tmp4 = fill_with_spaces (tmp4, chartype,
3911 fold_build2_loc (input_location, MINUS_EXPR,
3912 TREE_TYPE(dlen), dlen, slen));
3914 gfc_init_block (&tempblock);
3915 gfc_add_expr_to_block (&tempblock, tmp3);
3916 gfc_add_expr_to_block (&tempblock, tmp4);
3917 tmp3 = gfc_finish_block (&tempblock);
3919 /* The whole copy_string function is there. */
3920 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3922 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3923 build_empty_stmt (input_location));
3924 gfc_add_expr_to_block (block, tmp);
3928 /* Translate a statement function.
3929 The value of a statement function reference is obtained by evaluating the
3930 expression using the values of the actual arguments for the values of the
3931 corresponding dummy arguments. */
3934 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3938 gfc_formal_arglist *fargs;
3939 gfc_actual_arglist *args;
3942 gfc_saved_var *saved_vars;
3948 sym = expr->symtree->n.sym;
3949 args = expr->value.function.actual;
3950 gfc_init_se (&lse, NULL);
3951 gfc_init_se (&rse, NULL);
3954 for (fargs = sym->formal; fargs; fargs = fargs->next)
3956 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3957 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3959 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3961 /* Each dummy shall be specified, explicitly or implicitly, to be
3963 gcc_assert (fargs->sym->attr.dimension == 0);
3966 if (fsym->ts.type == BT_CHARACTER)
3968 /* Copy string arguments. */
3971 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3972 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3974 /* Create a temporary to hold the value. */
3975 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3976 fsym->ts.u.cl->backend_decl
3977 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3979 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3980 temp_vars[n] = gfc_create_var (type, fsym->name);
3982 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3984 gfc_conv_expr (&rse, args->expr);
3985 gfc_conv_string_parameter (&rse);
3986 gfc_add_block_to_block (&se->pre, &lse.pre);
3987 gfc_add_block_to_block (&se->pre, &rse.pre);
3989 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
3990 rse.string_length, rse.expr, fsym->ts.kind);
3991 gfc_add_block_to_block (&se->pre, &lse.post);
3992 gfc_add_block_to_block (&se->pre, &rse.post);
3996 /* For everything else, just evaluate the expression. */
3998 /* Create a temporary to hold the value. */
3999 type = gfc_typenode_for_spec (&fsym->ts);
4000 temp_vars[n] = gfc_create_var (type, fsym->name);
4002 gfc_conv_expr (&lse, args->expr);
4004 gfc_add_block_to_block (&se->pre, &lse.pre);
4005 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4006 gfc_add_block_to_block (&se->pre, &lse.post);
4012 /* Use the temporary variables in place of the real ones. */
4013 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4014 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4016 gfc_conv_expr (se, sym->value);
4018 if (sym->ts.type == BT_CHARACTER)
4020 gfc_conv_const_charlen (sym->ts.u.cl);
4022 /* Force the expression to the correct length. */
4023 if (!INTEGER_CST_P (se->string_length)
4024 || tree_int_cst_lt (se->string_length,
4025 sym->ts.u.cl->backend_decl))
4027 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4028 tmp = gfc_create_var (type, sym->name);
4029 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4030 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4031 sym->ts.kind, se->string_length, se->expr,
4035 se->string_length = sym->ts.u.cl->backend_decl;
4038 /* Restore the original variables. */
4039 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4040 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4041 gfc_free (saved_vars);
4045 /* Translate a function expression. */
4048 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4052 if (expr->value.function.isym)
4054 gfc_conv_intrinsic_function (se, expr);
4058 /* We distinguish statement functions from general functions to improve
4059 runtime performance. */
4060 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4062 gfc_conv_statement_function (se, expr);
4066 /* expr.value.function.esym is the resolved (specific) function symbol for
4067 most functions. However this isn't set for dummy procedures. */
4068 sym = expr->value.function.esym;
4070 sym = expr->symtree->n.sym;
4072 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4076 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4079 is_zero_initializer_p (gfc_expr * expr)
4081 if (expr->expr_type != EXPR_CONSTANT)
4084 /* We ignore constants with prescribed memory representations for now. */
4085 if (expr->representation.string)
4088 switch (expr->ts.type)
4091 return mpz_cmp_si (expr->value.integer, 0) == 0;
4094 return mpfr_zero_p (expr->value.real)
4095 && MPFR_SIGN (expr->value.real) >= 0;
4098 return expr->value.logical == 0;
4101 return mpfr_zero_p (mpc_realref (expr->value.complex))
4102 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4103 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4104 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4114 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4116 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4117 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4119 gfc_conv_tmp_array_ref (se);
4123 /* Build a static initializer. EXPR is the expression for the initial value.
4124 The other parameters describe the variable of the component being
4125 initialized. EXPR may be null. */
4128 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4129 bool array, bool pointer, bool procptr)
4133 if (!(expr || pointer || procptr))
4136 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4137 (these are the only two iso_c_binding derived types that can be
4138 used as initialization expressions). If so, we need to modify
4139 the 'expr' to be that for a (void *). */
4140 if (expr != NULL && expr->ts.type == BT_DERIVED
4141 && expr->ts.is_iso_c && expr->ts.u.derived)
4143 gfc_symbol *derived = expr->ts.u.derived;
4145 /* The derived symbol has already been converted to a (void *). Use
4147 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4148 expr->ts.f90_type = derived->ts.f90_type;
4150 gfc_init_se (&se, NULL);
4151 gfc_conv_constant (&se, expr);
4152 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4156 if (array && !procptr)
4159 /* Arrays need special handling. */
4161 ctor = gfc_build_null_descriptor (type);
4162 /* Special case assigning an array to zero. */
4163 else if (is_zero_initializer_p (expr))
4164 ctor = build_constructor (type, NULL);
4166 ctor = gfc_conv_array_initializer (type, expr);
4167 TREE_STATIC (ctor) = 1;
4170 else if (pointer || procptr)
4172 if (!expr || expr->expr_type == EXPR_NULL)
4173 return fold_convert (type, null_pointer_node);
4176 gfc_init_se (&se, NULL);
4177 se.want_pointer = 1;
4178 gfc_conv_expr (&se, expr);
4179 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4189 gfc_init_se (&se, NULL);
4190 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4191 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4193 gfc_conv_structure (&se, expr, 1);
4194 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4195 TREE_STATIC (se.expr) = 1;
4200 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4201 TREE_STATIC (ctor) = 1;
4206 gfc_init_se (&se, NULL);
4207 gfc_conv_constant (&se, expr);
4208 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4215 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4227 gfc_start_block (&block);
4229 /* Initialize the scalarizer. */
4230 gfc_init_loopinfo (&loop);
4232 gfc_init_se (&lse, NULL);
4233 gfc_init_se (&rse, NULL);
4236 rss = gfc_walk_expr (expr);
4237 if (rss == gfc_ss_terminator)
4239 /* The rhs is scalar. Add a ss for the expression. */
4240 rss = gfc_get_ss ();
4241 rss->next = gfc_ss_terminator;
4242 rss->type = GFC_SS_SCALAR;
4246 /* Create a SS for the destination. */
4247 lss = gfc_get_ss ();
4248 lss->type = GFC_SS_COMPONENT;
4250 lss->shape = gfc_get_shape (cm->as->rank);
4251 lss->next = gfc_ss_terminator;
4252 lss->data.info.dimen = cm->as->rank;
4253 lss->data.info.descriptor = dest;
4254 lss->data.info.data = gfc_conv_array_data (dest);
4255 lss->data.info.offset = gfc_conv_array_offset (dest);
4256 for (n = 0; n < cm->as->rank; n++)
4258 lss->data.info.dim[n] = n;
4259 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4260 lss->data.info.stride[n] = gfc_index_one_node;
4262 mpz_init (lss->shape[n]);
4263 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4264 cm->as->lower[n]->value.integer);
4265 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4268 /* Associate the SS with the loop. */
4269 gfc_add_ss_to_loop (&loop, lss);
4270 gfc_add_ss_to_loop (&loop, rss);
4272 /* Calculate the bounds of the scalarization. */
4273 gfc_conv_ss_startstride (&loop);
4275 /* Setup the scalarizing loops. */
4276 gfc_conv_loop_setup (&loop, &expr->where);
4278 /* Setup the gfc_se structures. */
4279 gfc_copy_loopinfo_to_se (&lse, &loop);
4280 gfc_copy_loopinfo_to_se (&rse, &loop);
4283 gfc_mark_ss_chain_used (rss, 1);
4285 gfc_mark_ss_chain_used (lss, 1);
4287 /* Start the scalarized loop body. */
4288 gfc_start_scalarized_body (&loop, &body);
4290 gfc_conv_tmp_array_ref (&lse);
4291 if (cm->ts.type == BT_CHARACTER)
4292 lse.string_length = cm->ts.u.cl->backend_decl;
4294 gfc_conv_expr (&rse, expr);
4296 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4297 gfc_add_expr_to_block (&body, tmp);
4299 gcc_assert (rse.ss == gfc_ss_terminator);
4301 /* Generate the copying loops. */
4302 gfc_trans_scalarizing_loops (&loop, &body);
4304 /* Wrap the whole thing up. */
4305 gfc_add_block_to_block (&block, &loop.pre);
4306 gfc_add_block_to_block (&block, &loop.post);
4308 for (n = 0; n < cm->as->rank; n++)
4309 mpz_clear (lss->shape[n]);
4310 gfc_free (lss->shape);
4312 gfc_cleanup_loop (&loop);
4314 return gfc_finish_block (&block);
4319 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4330 gfc_expr *arg = NULL;
4332 gfc_start_block (&block);
4333 gfc_init_se (&se, NULL);
4335 /* Get the descriptor for the expressions. */
4336 rss = gfc_walk_expr (expr);
4337 se.want_pointer = 0;
4338 gfc_conv_expr_descriptor (&se, expr, rss);
4339 gfc_add_block_to_block (&block, &se.pre);
4340 gfc_add_modify (&block, dest, se.expr);
4342 /* Deal with arrays of derived types with allocatable components. */
4343 if (cm->ts.type == BT_DERIVED
4344 && cm->ts.u.derived->attr.alloc_comp)
4345 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4349 tmp = gfc_duplicate_allocatable (dest, se.expr,
4350 TREE_TYPE(cm->backend_decl),
4353 gfc_add_expr_to_block (&block, tmp);
4354 gfc_add_block_to_block (&block, &se.post);
4356 if (expr->expr_type != EXPR_VARIABLE)
4357 gfc_conv_descriptor_data_set (&block, se.expr,
4360 /* We need to know if the argument of a conversion function is a
4361 variable, so that the correct lower bound can be used. */
4362 if (expr->expr_type == EXPR_FUNCTION
4363 && expr->value.function.isym
4364 && expr->value.function.isym->conversion
4365 && expr->value.function.actual->expr
4366 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4367 arg = expr->value.function.actual->expr;
4369 /* Obtain the array spec of full array references. */
4371 as = gfc_get_full_arrayspec_from_expr (arg);
4373 as = gfc_get_full_arrayspec_from_expr (expr);
4375 /* Shift the lbound and ubound of temporaries to being unity,
4376 rather than zero, based. Always calculate the offset. */
4377 offset = gfc_conv_descriptor_offset_get (dest);
4378 gfc_add_modify (&block, offset, gfc_index_zero_node);
4379 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4381 for (n = 0; n < expr->rank; n++)
4386 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4387 TODO It looks as if gfc_conv_expr_descriptor should return
4388 the correct bounds and that the following should not be
4389 necessary. This would simplify gfc_conv_intrinsic_bound
4391 if (as && as->lower[n])
4394 gfc_init_se (&lbse, NULL);
4395 gfc_conv_expr (&lbse, as->lower[n]);
4396 gfc_add_block_to_block (&block, &lbse.pre);
4397 lbound = gfc_evaluate_now (lbse.expr, &block);
4401 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4402 lbound = gfc_conv_descriptor_lbound_get (tmp,
4406 lbound = gfc_conv_descriptor_lbound_get (dest,
4409 lbound = gfc_index_one_node;
4411 lbound = fold_convert (gfc_array_index_type, lbound);
4413 /* Shift the bounds and set the offset accordingly. */
4414 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4415 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4416 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4417 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4419 gfc_conv_descriptor_ubound_set (&block, dest,
4420 gfc_rank_cst[n], tmp);
4421 gfc_conv_descriptor_lbound_set (&block, dest,
4422 gfc_rank_cst[n], lbound);
4424 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4425 gfc_conv_descriptor_lbound_get (dest,
4427 gfc_conv_descriptor_stride_get (dest,
4429 gfc_add_modify (&block, tmp2, tmp);
4430 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4432 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4437 /* If a conversion expression has a null data pointer
4438 argument, nullify the allocatable component. */
4442 if (arg->symtree->n.sym->attr.allocatable
4443 || arg->symtree->n.sym->attr.pointer)
4445 non_null_expr = gfc_finish_block (&block);
4446 gfc_start_block (&block);
4447 gfc_conv_descriptor_data_set (&block, dest,
4449 null_expr = gfc_finish_block (&block);
4450 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4451 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4452 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4453 return build3_v (COND_EXPR, tmp,
4454 null_expr, non_null_expr);
4458 return gfc_finish_block (&block);
4462 /* Assign a single component of a derived type constructor. */
4465 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4473 gfc_start_block (&block);
4475 if (cm->attr.pointer)
4477 gfc_init_se (&se, NULL);
4478 /* Pointer component. */
4479 if (cm->attr.dimension)
4481 /* Array pointer. */
4482 if (expr->expr_type == EXPR_NULL)
4483 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4486 rss = gfc_walk_expr (expr);
4487 se.direct_byref = 1;
4489 gfc_conv_expr_descriptor (&se, expr, rss);
4490 gfc_add_block_to_block (&block, &se.pre);
4491 gfc_add_block_to_block (&block, &se.post);
4496 /* Scalar pointers. */
4497 se.want_pointer = 1;
4498 gfc_conv_expr (&se, expr);
4499 gfc_add_block_to_block (&block, &se.pre);
4500 gfc_add_modify (&block, dest,
4501 fold_convert (TREE_TYPE (dest), se.expr));
4502 gfc_add_block_to_block (&block, &se.post);
4505 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4507 /* NULL initialization for CLASS components. */
4508 tmp = gfc_trans_structure_assign (dest,
4509 gfc_class_null_initializer (&cm->ts));
4510 gfc_add_expr_to_block (&block, tmp);
4512 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4514 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4515 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4516 else if (cm->attr.allocatable)
4518 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4519 gfc_add_expr_to_block (&block, tmp);
4523 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4524 gfc_add_expr_to_block (&block, tmp);
4527 else if (expr->ts.type == BT_DERIVED)
4529 if (expr->expr_type != EXPR_STRUCTURE)
4531 gfc_init_se (&se, NULL);
4532 gfc_conv_expr (&se, expr);
4533 gfc_add_block_to_block (&block, &se.pre);
4534 gfc_add_modify (&block, dest,
4535 fold_convert (TREE_TYPE (dest), se.expr));
4536 gfc_add_block_to_block (&block, &se.post);
4540 /* Nested constructors. */
4541 tmp = gfc_trans_structure_assign (dest, expr);
4542 gfc_add_expr_to_block (&block, tmp);
4547 /* Scalar component. */
4548 gfc_init_se (&se, NULL);
4549 gfc_init_se (&lse, NULL);
4551 gfc_conv_expr (&se, expr);
4552 if (cm->ts.type == BT_CHARACTER)
4553 lse.string_length = cm->ts.u.cl->backend_decl;
4555 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4556 gfc_add_expr_to_block (&block, tmp);
4558 return gfc_finish_block (&block);
4561 /* Assign a derived type constructor to a variable. */
4564 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4572 gfc_start_block (&block);
4573 cm = expr->ts.u.derived->components;
4575 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4576 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4577 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4581 gcc_assert (cm->backend_decl == NULL);
4582 gfc_init_se (&se, NULL);
4583 gfc_init_se (&lse, NULL);
4584 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4586 gfc_add_modify (&block, lse.expr,
4587 fold_convert (TREE_TYPE (lse.expr), se.expr));
4589 return gfc_finish_block (&block);
4592 for (c = gfc_constructor_first (expr->value.constructor);
4593 c; c = gfc_constructor_next (c), cm = cm->next)
4595 /* Skip absent members in default initializers. */
4599 field = cm->backend_decl;
4600 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4601 dest, field, NULL_TREE);
4602 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4603 gfc_add_expr_to_block (&block, tmp);
4605 return gfc_finish_block (&block);
4608 /* Build an expression for a constructor. If init is nonzero then
4609 this is part of a static variable initializer. */
4612 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4619 VEC(constructor_elt,gc) *v = NULL;
4621 gcc_assert (se->ss == NULL);
4622 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4623 type = gfc_typenode_for_spec (&expr->ts);
4627 /* Create a temporary variable and fill it in. */
4628 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4629 tmp = gfc_trans_structure_assign (se->expr, expr);
4630 gfc_add_expr_to_block (&se->pre, tmp);
4634 cm = expr->ts.u.derived->components;
4636 for (c = gfc_constructor_first (expr->value.constructor);
4637 c; c = gfc_constructor_next (c), cm = cm->next)
4639 /* Skip absent members in default initializers and allocatable
4640 components. Although the latter have a default initializer
4641 of EXPR_NULL,... by default, the static nullify is not needed
4642 since this is done every time we come into scope. */
4643 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4646 if (strcmp (cm->name, "_size") == 0)
4648 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4649 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4651 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4652 && strcmp (cm->name, "_extends") == 0)
4656 vtabs = cm->initializer->symtree->n.sym;
4657 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4658 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4662 val = gfc_conv_initializer (c->expr, &cm->ts,
4663 TREE_TYPE (cm->backend_decl),
4664 cm->attr.dimension, cm->attr.pointer,
4665 cm->attr.proc_pointer);
4667 /* Append it to the constructor list. */
4668 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4671 se->expr = build_constructor (type, v);
4673 TREE_CONSTANT (se->expr) = 1;
4677 /* Translate a substring expression. */
4680 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4686 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4688 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4689 expr->value.character.length,
4690 expr->value.character.string);
4692 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4693 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4696 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4700 /* Entry point for expression translation. Evaluates a scalar quantity.
4701 EXPR is the expression to be translated, and SE is the state structure if
4702 called from within the scalarized. */
4705 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4707 if (se->ss && se->ss->expr == expr
4708 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4710 /* Substitute a scalar expression evaluated outside the scalarization
4712 se->expr = se->ss->data.scalar.expr;
4713 if (se->ss->type == GFC_SS_REFERENCE)
4714 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4715 se->string_length = se->ss->string_length;
4716 gfc_advance_se_ss_chain (se);
4720 /* We need to convert the expressions for the iso_c_binding derived types.
4721 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4722 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4723 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4724 updated to be an integer with a kind equal to the size of a (void *). */
4725 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4726 && expr->ts.u.derived->attr.is_iso_c)
4728 if (expr->expr_type == EXPR_VARIABLE
4729 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4730 || expr->symtree->n.sym->intmod_sym_id
4731 == ISOCBINDING_NULL_FUNPTR))
4733 /* Set expr_type to EXPR_NULL, which will result in
4734 null_pointer_node being used below. */
4735 expr->expr_type = EXPR_NULL;
4739 /* Update the type/kind of the expression to be what the new
4740 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4741 expr->ts.type = expr->ts.u.derived->ts.type;
4742 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4743 expr->ts.kind = expr->ts.u.derived->ts.kind;
4747 switch (expr->expr_type)
4750 gfc_conv_expr_op (se, expr);
4754 gfc_conv_function_expr (se, expr);
4758 gfc_conv_constant (se, expr);
4762 gfc_conv_variable (se, expr);
4766 se->expr = null_pointer_node;
4769 case EXPR_SUBSTRING:
4770 gfc_conv_substring_expr (se, expr);
4773 case EXPR_STRUCTURE:
4774 gfc_conv_structure (se, expr, 0);
4778 gfc_conv_array_constructor_expr (se, expr);
4787 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4788 of an assignment. */
4790 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4792 gfc_conv_expr (se, expr);
4793 /* All numeric lvalues should have empty post chains. If not we need to
4794 figure out a way of rewriting an lvalue so that it has no post chain. */
4795 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4798 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4799 numeric expressions. Used for scalar values where inserting cleanup code
4802 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4806 gcc_assert (expr->ts.type != BT_CHARACTER);
4807 gfc_conv_expr (se, expr);
4810 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4811 gfc_add_modify (&se->pre, val, se->expr);
4813 gfc_add_block_to_block (&se->pre, &se->post);
4817 /* Helper to translate an expression and convert it to a particular type. */
4819 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4821 gfc_conv_expr_val (se, expr);
4822 se->expr = convert (type, se->expr);
4826 /* Converts an expression so that it can be passed by reference. Scalar
4830 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4834 if (se->ss && se->ss->expr == expr
4835 && se->ss->type == GFC_SS_REFERENCE)
4837 /* Returns a reference to the scalar evaluated outside the loop
4839 gfc_conv_expr (se, expr);
4843 if (expr->ts.type == BT_CHARACTER)
4845 gfc_conv_expr (se, expr);
4846 gfc_conv_string_parameter (se);
4850 if (expr->expr_type == EXPR_VARIABLE)
4852 se->want_pointer = 1;
4853 gfc_conv_expr (se, expr);
4856 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4857 gfc_add_modify (&se->pre, var, se->expr);
4858 gfc_add_block_to_block (&se->pre, &se->post);
4864 if (expr->expr_type == EXPR_FUNCTION
4865 && ((expr->value.function.esym
4866 && expr->value.function.esym->result->attr.pointer
4867 && !expr->value.function.esym->result->attr.dimension)
4868 || (!expr->value.function.esym
4869 && expr->symtree->n.sym->attr.pointer
4870 && !expr->symtree->n.sym->attr.dimension)))
4872 se->want_pointer = 1;
4873 gfc_conv_expr (se, expr);
4874 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4875 gfc_add_modify (&se->pre, var, se->expr);
4881 gfc_conv_expr (se, expr);
4883 /* Create a temporary var to hold the value. */
4884 if (TREE_CONSTANT (se->expr))
4886 tree tmp = se->expr;
4887 STRIP_TYPE_NOPS (tmp);
4888 var = build_decl (input_location,
4889 CONST_DECL, NULL, TREE_TYPE (tmp));
4890 DECL_INITIAL (var) = tmp;
4891 TREE_STATIC (var) = 1;
4896 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4897 gfc_add_modify (&se->pre, var, se->expr);
4899 gfc_add_block_to_block (&se->pre, &se->post);
4901 /* Take the address of that value. */
4902 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4907 gfc_trans_pointer_assign (gfc_code * code)
4909 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4913 /* Generate code for a pointer assignment. */
4916 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4927 gfc_start_block (&block);
4929 gfc_init_se (&lse, NULL);
4931 lss = gfc_walk_expr (expr1);
4932 rss = gfc_walk_expr (expr2);
4933 if (lss == gfc_ss_terminator)
4935 /* Scalar pointers. */
4936 lse.want_pointer = 1;
4937 gfc_conv_expr (&lse, expr1);
4938 gcc_assert (rss == gfc_ss_terminator);
4939 gfc_init_se (&rse, NULL);
4940 rse.want_pointer = 1;
4941 gfc_conv_expr (&rse, expr2);
4943 if (expr1->symtree->n.sym->attr.proc_pointer
4944 && expr1->symtree->n.sym->attr.dummy)
4945 lse.expr = build_fold_indirect_ref_loc (input_location,
4948 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4949 && expr2->symtree->n.sym->attr.dummy)
4950 rse.expr = build_fold_indirect_ref_loc (input_location,
4953 gfc_add_block_to_block (&block, &lse.pre);
4954 gfc_add_block_to_block (&block, &rse.pre);
4956 /* Check character lengths if character expression. The test is only
4957 really added if -fbounds-check is enabled. Exclude deferred
4958 character length lefthand sides. */
4959 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4960 && !(expr1->ts.deferred
4961 && (TREE_CODE (lse.string_length) == VAR_DECL))
4962 && !expr1->symtree->n.sym->attr.proc_pointer
4963 && !gfc_is_proc_ptr_comp (expr1, NULL))
4965 gcc_assert (expr2->ts.type == BT_CHARACTER);
4966 gcc_assert (lse.string_length && rse.string_length);
4967 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4968 lse.string_length, rse.string_length,
4972 /* The assignment to an deferred character length sets the string
4973 length to that of the rhs. */
4974 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4976 if (expr2->expr_type != EXPR_NULL)
4977 gfc_add_modify (&block, lse.string_length, rse.string_length);
4979 gfc_add_modify (&block, lse.string_length,
4980 build_int_cst (gfc_charlen_type_node, 0));
4983 gfc_add_modify (&block, lse.expr,
4984 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4986 gfc_add_block_to_block (&block, &rse.post);
4987 gfc_add_block_to_block (&block, &lse.post);
4994 tree strlen_rhs = NULL_TREE;
4996 /* Array pointer. Find the last reference on the LHS and if it is an
4997 array section ref, we're dealing with bounds remapping. In this case,
4998 set it to AR_FULL so that gfc_conv_expr_descriptor does
4999 not see it and process the bounds remapping afterwards explicitely. */
5000 for (remap = expr1->ref; remap; remap = remap->next)
5001 if (!remap->next && remap->type == REF_ARRAY
5002 && remap->u.ar.type == AR_SECTION)
5004 remap->u.ar.type = AR_FULL;
5007 rank_remap = (remap && remap->u.ar.end[0]);
5009 gfc_conv_expr_descriptor (&lse, expr1, lss);
5010 strlen_lhs = lse.string_length;
5013 if (expr2->expr_type == EXPR_NULL)
5015 /* Just set the data pointer to null. */
5016 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5018 else if (rank_remap)
5020 /* If we are rank-remapping, just get the RHS's descriptor and
5021 process this later on. */
5022 gfc_init_se (&rse, NULL);
5023 rse.direct_byref = 1;
5024 rse.byref_noassign = 1;
5025 gfc_conv_expr_descriptor (&rse, expr2, rss);
5026 strlen_rhs = rse.string_length;
5028 else if (expr2->expr_type == EXPR_VARIABLE)
5030 /* Assign directly to the LHS's descriptor. */
5031 lse.direct_byref = 1;
5032 gfc_conv_expr_descriptor (&lse, expr2, rss);
5033 strlen_rhs = lse.string_length;
5035 /* If this is a subreference array pointer assignment, use the rhs
5036 descriptor element size for the lhs span. */
5037 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5039 decl = expr1->symtree->n.sym->backend_decl;
5040 gfc_init_se (&rse, NULL);
5041 rse.descriptor_only = 1;
5042 gfc_conv_expr (&rse, expr2);
5043 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5044 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5045 if (!INTEGER_CST_P (tmp))
5046 gfc_add_block_to_block (&lse.post, &rse.pre);
5047 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5052 /* Assign to a temporary descriptor and then copy that
5053 temporary to the pointer. */
5054 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5057 lse.direct_byref = 1;
5058 gfc_conv_expr_descriptor (&lse, expr2, rss);
5059 strlen_rhs = lse.string_length;
5060 gfc_add_modify (&lse.pre, desc, tmp);
5063 gfc_add_block_to_block (&block, &lse.pre);
5065 gfc_add_block_to_block (&block, &rse.pre);
5067 /* If we do bounds remapping, update LHS descriptor accordingly. */
5071 gcc_assert (remap->u.ar.dimen == expr1->rank);
5075 /* Do rank remapping. We already have the RHS's descriptor
5076 converted in rse and now have to build the correct LHS
5077 descriptor for it. */
5081 tree lbound, ubound;
5084 dtype = gfc_conv_descriptor_dtype (desc);
5085 tmp = gfc_get_dtype (TREE_TYPE (desc));
5086 gfc_add_modify (&block, dtype, tmp);
5088 /* Copy data pointer. */
5089 data = gfc_conv_descriptor_data_get (rse.expr);
5090 gfc_conv_descriptor_data_set (&block, desc, data);
5092 /* Copy offset but adjust it such that it would correspond
5093 to a lbound of zero. */
5094 offs = gfc_conv_descriptor_offset_get (rse.expr);
5095 for (dim = 0; dim < expr2->rank; ++dim)
5097 stride = gfc_conv_descriptor_stride_get (rse.expr,
5099 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5101 tmp = fold_build2_loc (input_location, MULT_EXPR,
5102 gfc_array_index_type, stride, lbound);
5103 offs = fold_build2_loc (input_location, PLUS_EXPR,
5104 gfc_array_index_type, offs, tmp);
5106 gfc_conv_descriptor_offset_set (&block, desc, offs);
5108 /* Set the bounds as declared for the LHS and calculate strides as
5109 well as another offset update accordingly. */
5110 stride = gfc_conv_descriptor_stride_get (rse.expr,
5112 for (dim = 0; dim < expr1->rank; ++dim)
5117 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5119 /* Convert declared bounds. */
5120 gfc_init_se (&lower_se, NULL);
5121 gfc_init_se (&upper_se, NULL);
5122 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5123 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5125 gfc_add_block_to_block (&block, &lower_se.pre);
5126 gfc_add_block_to_block (&block, &upper_se.pre);
5128 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5129 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5131 lbound = gfc_evaluate_now (lbound, &block);
5132 ubound = gfc_evaluate_now (ubound, &block);
5134 gfc_add_block_to_block (&block, &lower_se.post);
5135 gfc_add_block_to_block (&block, &upper_se.post);
5137 /* Set bounds in descriptor. */
5138 gfc_conv_descriptor_lbound_set (&block, desc,
5139 gfc_rank_cst[dim], lbound);
5140 gfc_conv_descriptor_ubound_set (&block, desc,
5141 gfc_rank_cst[dim], ubound);
5144 stride = gfc_evaluate_now (stride, &block);
5145 gfc_conv_descriptor_stride_set (&block, desc,
5146 gfc_rank_cst[dim], stride);
5148 /* Update offset. */
5149 offs = gfc_conv_descriptor_offset_get (desc);
5150 tmp = fold_build2_loc (input_location, MULT_EXPR,
5151 gfc_array_index_type, lbound, stride);
5152 offs = fold_build2_loc (input_location, MINUS_EXPR,
5153 gfc_array_index_type, offs, tmp);
5154 offs = gfc_evaluate_now (offs, &block);
5155 gfc_conv_descriptor_offset_set (&block, desc, offs);
5157 /* Update stride. */
5158 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5159 stride = fold_build2_loc (input_location, MULT_EXPR,
5160 gfc_array_index_type, stride, tmp);
5165 /* Bounds remapping. Just shift the lower bounds. */
5167 gcc_assert (expr1->rank == expr2->rank);
5169 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5173 gcc_assert (remap->u.ar.start[dim]);
5174 gcc_assert (!remap->u.ar.end[dim]);
5175 gfc_init_se (&lbound_se, NULL);
5176 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5178 gfc_add_block_to_block (&block, &lbound_se.pre);
5179 gfc_conv_shift_descriptor_lbound (&block, desc,
5180 dim, lbound_se.expr);
5181 gfc_add_block_to_block (&block, &lbound_se.post);
5186 /* Check string lengths if applicable. The check is only really added
5187 to the output code if -fbounds-check is enabled. */
5188 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5190 gcc_assert (expr2->ts.type == BT_CHARACTER);
5191 gcc_assert (strlen_lhs && strlen_rhs);
5192 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5193 strlen_lhs, strlen_rhs, &block);
5196 /* If rank remapping was done, check with -fcheck=bounds that
5197 the target is at least as large as the pointer. */
5198 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5204 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5205 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5207 lsize = gfc_evaluate_now (lsize, &block);
5208 rsize = gfc_evaluate_now (rsize, &block);
5209 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5212 msg = _("Target of rank remapping is too small (%ld < %ld)");
5213 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5217 gfc_add_block_to_block (&block, &lse.post);
5219 gfc_add_block_to_block (&block, &rse.post);
5222 return gfc_finish_block (&block);
5226 /* Makes sure se is suitable for passing as a function string parameter. */
5227 /* TODO: Need to check all callers of this function. It may be abused. */
5230 gfc_conv_string_parameter (gfc_se * se)
5234 if (TREE_CODE (se->expr) == STRING_CST)
5236 type = TREE_TYPE (TREE_TYPE (se->expr));
5237 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5241 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5243 if (TREE_CODE (se->expr) != INDIRECT_REF)
5245 type = TREE_TYPE (se->expr);
5246 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5250 type = gfc_get_character_type_len (gfc_default_character_kind,
5252 type = build_pointer_type (type);
5253 se->expr = gfc_build_addr_expr (type, se->expr);
5257 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5261 /* Generate code for assignment of scalar variables. Includes character
5262 strings and derived types with allocatable components.
5263 If you know that the LHS has no allocations, set dealloc to false. */
5266 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5267 bool l_is_temp, bool r_is_var, bool dealloc)
5273 gfc_init_block (&block);
5275 if (ts.type == BT_CHARACTER)
5280 if (lse->string_length != NULL_TREE)
5282 gfc_conv_string_parameter (lse);
5283 gfc_add_block_to_block (&block, &lse->pre);
5284 llen = lse->string_length;
5287 if (rse->string_length != NULL_TREE)
5289 gcc_assert (rse->string_length != NULL_TREE);
5290 gfc_conv_string_parameter (rse);
5291 gfc_add_block_to_block (&block, &rse->pre);
5292 rlen = rse->string_length;
5295 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5296 rse->expr, ts.kind);
5298 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5302 /* Are the rhs and the lhs the same? */
5305 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5306 gfc_build_addr_expr (NULL_TREE, lse->expr),
5307 gfc_build_addr_expr (NULL_TREE, rse->expr));
5308 cond = gfc_evaluate_now (cond, &lse->pre);
5311 /* Deallocate the lhs allocated components as long as it is not
5312 the same as the rhs. This must be done following the assignment
5313 to prevent deallocating data that could be used in the rhs
5315 if (!l_is_temp && dealloc)
5317 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5318 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5320 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5322 gfc_add_expr_to_block (&lse->post, tmp);
5325 gfc_add_block_to_block (&block, &rse->pre);
5326 gfc_add_block_to_block (&block, &lse->pre);
5328 gfc_add_modify (&block, lse->expr,
5329 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5331 /* Do a deep copy if the rhs is a variable, if it is not the
5335 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5336 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5338 gfc_add_expr_to_block (&block, tmp);
5341 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5343 gfc_add_block_to_block (&block, &lse->pre);
5344 gfc_add_block_to_block (&block, &rse->pre);
5345 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5346 TREE_TYPE (lse->expr), rse->expr);
5347 gfc_add_modify (&block, lse->expr, tmp);
5351 gfc_add_block_to_block (&block, &lse->pre);
5352 gfc_add_block_to_block (&block, &rse->pre);
5354 gfc_add_modify (&block, lse->expr,
5355 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5358 gfc_add_block_to_block (&block, &lse->post);
5359 gfc_add_block_to_block (&block, &rse->post);
5361 return gfc_finish_block (&block);
5365 /* There are quite a lot of restrictions on the optimisation in using an
5366 array function assign without a temporary. */
5369 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5372 bool seen_array_ref;
5374 gfc_symbol *sym = expr1->symtree->n.sym;
5376 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5377 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5380 /* Elemental functions are scalarized so that they don't need a
5381 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5382 they would need special treatment in gfc_trans_arrayfunc_assign. */
5383 if (expr2->value.function.esym != NULL
5384 && expr2->value.function.esym->attr.elemental)
5387 /* Need a temporary if rhs is not FULL or a contiguous section. */
5388 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5391 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5392 if (gfc_ref_needs_temporary_p (expr1->ref))
5395 /* Functions returning pointers need temporaries. */
5396 if (expr2->symtree->n.sym->attr.pointer
5397 || expr2->symtree->n.sym->attr.allocatable)
5400 /* Character array functions need temporaries unless the
5401 character lengths are the same. */
5402 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5404 if (expr1->ts.u.cl->length == NULL
5405 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5408 if (expr2->ts.u.cl->length == NULL
5409 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5412 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5413 expr2->ts.u.cl->length->value.integer) != 0)
5417 /* Check that no LHS component references appear during an array
5418 reference. This is needed because we do not have the means to
5419 span any arbitrary stride with an array descriptor. This check
5420 is not needed for the rhs because the function result has to be
5422 seen_array_ref = false;
5423 for (ref = expr1->ref; ref; ref = ref->next)
5425 if (ref->type == REF_ARRAY)
5426 seen_array_ref= true;
5427 else if (ref->type == REF_COMPONENT && seen_array_ref)
5431 /* Check for a dependency. */
5432 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5433 expr2->value.function.esym,
5434 expr2->value.function.actual,
5438 /* If we have reached here with an intrinsic function, we do not
5439 need a temporary. */
5440 if (expr2->value.function.isym)
5443 /* If the LHS is a dummy, we need a temporary if it is not
5445 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5448 /* If the lhs has been host_associated, is in common, a pointer or is
5449 a target and the function is not using a RESULT variable, aliasing
5450 can occur and a temporary is needed. */
5451 if ((sym->attr.host_assoc
5452 || sym->attr.in_common
5453 || sym->attr.pointer
5454 || sym->attr.cray_pointee
5455 || sym->attr.target)
5456 && expr2->symtree != NULL
5457 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5460 /* A PURE function can unconditionally be called without a temporary. */
5461 if (expr2->value.function.esym != NULL
5462 && expr2->value.function.esym->attr.pure)
5465 /* Implicit_pure functions are those which could legally be declared
5467 if (expr2->value.function.esym != NULL
5468 && expr2->value.function.esym->attr.implicit_pure)
5471 if (!sym->attr.use_assoc
5472 && !sym->attr.in_common
5473 && !sym->attr.pointer
5474 && !sym->attr.target
5475 && !sym->attr.cray_pointee
5476 && expr2->value.function.esym)
5478 /* A temporary is not needed if the function is not contained and
5479 the variable is local or host associated and not a pointer or
5481 if (!expr2->value.function.esym->attr.contained)
5484 /* A temporary is not needed if the lhs has never been host
5485 associated and the procedure is contained. */
5486 else if (!sym->attr.host_assoc)
5489 /* A temporary is not needed if the variable is local and not
5490 a pointer, a target or a result. */
5492 && expr2->value.function.esym->ns == sym->ns->parent)
5496 /* Default to temporary use. */
5501 /* Provide the loop info so that the lhs descriptor can be built for
5502 reallocatable assignments from extrinsic function calls. */
5505 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
5508 /* Signal that the function call should not be made by
5509 gfc_conv_loop_setup. */
5510 se->ss->is_alloc_lhs = 1;
5511 gfc_init_loopinfo (&loop);
5512 gfc_add_ss_to_loop (&loop, *ss);
5513 gfc_add_ss_to_loop (&loop, se->ss);
5514 gfc_conv_ss_startstride (&loop);
5515 gfc_conv_loop_setup (&loop, where);
5516 gfc_copy_loopinfo_to_se (se, &loop);
5517 gfc_add_block_to_block (&se->pre, &loop.pre);
5518 gfc_add_block_to_block (&se->pre, &loop.post);
5519 se->ss->is_alloc_lhs = 0;
5524 realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
5531 /* Use the allocation done by the library. */
5532 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5533 tmp = gfc_conv_descriptor_data_get (desc);
5534 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5535 gfc_add_expr_to_block (&se->pre, tmp);
5536 gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
5537 /* Unallocated, the descriptor does not have a dtype. */
5538 tmp = gfc_conv_descriptor_dtype (desc);
5539 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5541 offset = gfc_index_zero_node;
5542 tmp = gfc_index_one_node;
5543 /* Now reset the bounds from zero based to unity based. */
5544 for (n = 0 ; n < rank; n++)
5546 /* Accumulate the offset. */
5547 offset = fold_build2_loc (input_location, MINUS_EXPR,
5548 gfc_array_index_type,
5550 /* Now do the bounds. */
5551 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5552 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5553 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5554 gfc_array_index_type,
5555 tmp, gfc_index_one_node);
5556 gfc_conv_descriptor_lbound_set (&se->post, desc,
5558 gfc_index_one_node);
5559 gfc_conv_descriptor_ubound_set (&se->post, desc,
5560 gfc_rank_cst[n], tmp);
5562 /* The extent for the next contribution to offset. */
5563 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5564 gfc_array_index_type,
5565 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5566 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5567 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5568 gfc_array_index_type,
5569 tmp, gfc_index_one_node);
5571 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5576 /* Try to translate array(:) = func (...), where func is a transformational
5577 array function, without using a temporary. Returns NULL if this isn't the
5581 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5585 gfc_component *comp = NULL;
5587 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5590 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5592 gcc_assert (expr2->value.function.isym
5593 || (gfc_is_proc_ptr_comp (expr2, &comp)
5594 && comp && comp->attr.dimension)
5595 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5596 && expr2->value.function.esym->result->attr.dimension));
5598 ss = gfc_walk_expr (expr1);
5599 gcc_assert (ss != gfc_ss_terminator);
5600 gfc_init_se (&se, NULL);
5601 gfc_start_block (&se.pre);
5602 se.want_pointer = 1;
5604 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5606 if (expr1->ts.type == BT_DERIVED
5607 && expr1->ts.u.derived->attr.alloc_comp)
5610 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5612 gfc_add_expr_to_block (&se.pre, tmp);
5615 se.direct_byref = 1;
5616 se.ss = gfc_walk_expr (expr2);
5617 gcc_assert (se.ss != gfc_ss_terminator);
5619 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5620 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5621 Clearly, this cannot be done for an allocatable function result, since
5622 the shape of the result is unknown and, in any case, the function must
5623 correctly take care of the reallocation internally. For intrinsic
5624 calls, the array data is freed and the library takes care of allocation.
5625 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5627 if (gfc_option.flag_realloc_lhs
5628 && gfc_is_reallocatable_lhs (expr1)
5629 && !gfc_expr_attr (expr1).codimension
5630 && !gfc_is_coindexed (expr1)
5631 && !(expr2->value.function.esym
5632 && expr2->value.function.esym->result->attr.allocatable))
5634 if (!expr2->value.function.isym)
5636 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
5637 ss->is_alloc_lhs = 1;
5640 realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
5643 gfc_conv_function_expr (&se, expr2);
5644 gfc_add_block_to_block (&se.pre, &se.post);
5646 return gfc_finish_block (&se.pre);
5650 /* Try to efficiently translate array(:) = 0. Return NULL if this
5654 gfc_trans_zero_assign (gfc_expr * expr)
5656 tree dest, len, type;
5660 sym = expr->symtree->n.sym;
5661 dest = gfc_get_symbol_decl (sym);
5663 type = TREE_TYPE (dest);
5664 if (POINTER_TYPE_P (type))
5665 type = TREE_TYPE (type);
5666 if (!GFC_ARRAY_TYPE_P (type))
5669 /* Determine the length of the array. */
5670 len = GFC_TYPE_ARRAY_SIZE (type);
5671 if (!len || TREE_CODE (len) != INTEGER_CST)
5674 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5675 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5676 fold_convert (gfc_array_index_type, tmp));
5678 /* If we are zeroing a local array avoid taking its address by emitting
5680 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5681 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5682 dest, build_constructor (TREE_TYPE (dest), NULL));
5684 /* Convert arguments to the correct types. */
5685 dest = fold_convert (pvoid_type_node, dest);
5686 len = fold_convert (size_type_node, len);
5688 /* Construct call to __builtin_memset. */
5689 tmp = build_call_expr_loc (input_location,
5690 built_in_decls[BUILT_IN_MEMSET],
5691 3, dest, integer_zero_node, len);
5692 return fold_convert (void_type_node, tmp);
5696 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5697 that constructs the call to __builtin_memcpy. */
5700 gfc_build_memcpy_call (tree dst, tree src, tree len)
5704 /* Convert arguments to the correct types. */
5705 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5706 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5708 dst = fold_convert (pvoid_type_node, dst);
5710 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5711 src = gfc_build_addr_expr (pvoid_type_node, src);
5713 src = fold_convert (pvoid_type_node, src);
5715 len = fold_convert (size_type_node, len);
5717 /* Construct call to __builtin_memcpy. */
5718 tmp = build_call_expr_loc (input_location,
5719 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5720 return fold_convert (void_type_node, tmp);
5724 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5725 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5726 source/rhs, both are gfc_full_array_ref_p which have been checked for
5730 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5732 tree dst, dlen, dtype;
5733 tree src, slen, stype;
5736 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5737 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5739 dtype = TREE_TYPE (dst);
5740 if (POINTER_TYPE_P (dtype))
5741 dtype = TREE_TYPE (dtype);
5742 stype = TREE_TYPE (src);
5743 if (POINTER_TYPE_P (stype))
5744 stype = TREE_TYPE (stype);
5746 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5749 /* Determine the lengths of the arrays. */
5750 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5751 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5753 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5754 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5755 dlen, fold_convert (gfc_array_index_type, tmp));
5757 slen = GFC_TYPE_ARRAY_SIZE (stype);
5758 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5760 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5761 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5762 slen, fold_convert (gfc_array_index_type, tmp));
5764 /* Sanity check that they are the same. This should always be
5765 the case, as we should already have checked for conformance. */
5766 if (!tree_int_cst_equal (slen, dlen))
5769 return gfc_build_memcpy_call (dst, src, dlen);
5773 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5774 this can't be done. EXPR1 is the destination/lhs for which
5775 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5778 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5780 unsigned HOST_WIDE_INT nelem;
5786 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5790 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5791 dtype = TREE_TYPE (dst);
5792 if (POINTER_TYPE_P (dtype))
5793 dtype = TREE_TYPE (dtype);
5794 if (!GFC_ARRAY_TYPE_P (dtype))
5797 /* Determine the lengths of the array. */
5798 len = GFC_TYPE_ARRAY_SIZE (dtype);
5799 if (!len || TREE_CODE (len) != INTEGER_CST)
5802 /* Confirm that the constructor is the same size. */
5803 if (compare_tree_int (len, nelem) != 0)
5806 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5807 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5808 fold_convert (gfc_array_index_type, tmp));
5810 stype = gfc_typenode_for_spec (&expr2->ts);
5811 src = gfc_build_constant_array_constructor (expr2, stype);
5813 stype = TREE_TYPE (src);
5814 if (POINTER_TYPE_P (stype))
5815 stype = TREE_TYPE (stype);
5817 return gfc_build_memcpy_call (dst, src, len);
5821 /* Tells whether the expression is to be treated as a variable reference. */
5824 expr_is_variable (gfc_expr *expr)
5828 if (expr->expr_type == EXPR_VARIABLE)
5831 arg = gfc_get_noncopying_intrinsic_argument (expr);
5834 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5835 return expr_is_variable (arg);
5842 /* Is the lhs OK for automatic reallocation? */
5845 is_scalar_reallocatable_lhs (gfc_expr *expr)
5849 /* An allocatable variable with no reference. */
5850 if (expr->symtree->n.sym->attr.allocatable
5854 /* All that can be left are allocatable components. */
5855 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5856 && expr->symtree->n.sym->ts.type != BT_CLASS)
5857 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5860 /* Find an allocatable component ref last. */
5861 for (ref = expr->ref; ref; ref = ref->next)
5862 if (ref->type == REF_COMPONENT
5864 && ref->u.c.component->attr.allocatable)
5871 /* Allocate or reallocate scalar lhs, as necessary. */
5874 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5888 if (!expr1 || expr1->rank)
5891 if (!expr2 || expr2->rank)
5894 /* Since this is a scalar lhs, we can afford to do this. That is,
5895 there is no risk of side effects being repeated. */
5896 gfc_init_se (&lse, NULL);
5897 lse.want_pointer = 1;
5898 gfc_conv_expr (&lse, expr1);
5900 jump_label1 = gfc_build_label_decl (NULL_TREE);
5901 jump_label2 = gfc_build_label_decl (NULL_TREE);
5903 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5904 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5905 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5907 tmp = build3_v (COND_EXPR, cond,
5908 build1_v (GOTO_EXPR, jump_label1),
5909 build_empty_stmt (input_location));
5910 gfc_add_expr_to_block (block, tmp);
5912 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5914 /* Use the rhs string length and the lhs element size. */
5915 size = string_length;
5916 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5917 tmp = TYPE_SIZE_UNIT (tmp);
5918 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5919 TREE_TYPE (tmp), tmp,
5920 fold_convert (TREE_TYPE (tmp), size));
5924 /* Otherwise use the length in bytes of the rhs. */
5925 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5926 size_in_bytes = size;
5929 tmp = build_call_expr_loc (input_location,
5930 built_in_decls[BUILT_IN_MALLOC], 1,
5932 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5933 gfc_add_modify (block, lse.expr, tmp);
5934 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5936 /* Deferred characters need checking for lhs and rhs string
5937 length. Other deferred parameter variables will have to
5939 tmp = build1_v (GOTO_EXPR, jump_label2);
5940 gfc_add_expr_to_block (block, tmp);
5942 tmp = build1_v (LABEL_EXPR, jump_label1);
5943 gfc_add_expr_to_block (block, tmp);
5945 /* For a deferred length character, reallocate if lengths of lhs and
5946 rhs are different. */
5947 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5949 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5950 expr1->ts.u.cl->backend_decl, size);
5951 /* Jump past the realloc if the lengths are the same. */
5952 tmp = build3_v (COND_EXPR, cond,
5953 build1_v (GOTO_EXPR, jump_label2),
5954 build_empty_stmt (input_location));
5955 gfc_add_expr_to_block (block, tmp);
5956 tmp = build_call_expr_loc (input_location,
5957 built_in_decls[BUILT_IN_REALLOC], 2,
5958 fold_convert (pvoid_type_node, lse.expr),
5960 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5961 gfc_add_modify (block, lse.expr, tmp);
5962 tmp = build1_v (LABEL_EXPR, jump_label2);
5963 gfc_add_expr_to_block (block, tmp);
5965 /* Update the lhs character length. */
5966 size = string_length;
5967 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
5972 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5973 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5974 init_flag indicates initialization expressions and dealloc that no
5975 deallocate prior assignment is needed (if in doubt, set true). */
5978 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5984 gfc_ss *lss_section;
5991 bool scalar_to_array;
5996 /* Assignment of the form lhs = rhs. */
5997 gfc_start_block (&block);
5999 gfc_init_se (&lse, NULL);
6000 gfc_init_se (&rse, NULL);
6003 lss = gfc_walk_expr (expr1);
6004 if (gfc_is_reallocatable_lhs (expr1)
6005 && !(expr2->expr_type == EXPR_FUNCTION
6006 && expr2->value.function.isym != NULL))
6007 lss->is_alloc_lhs = 1;
6009 if (lss != gfc_ss_terminator)
6011 /* Allow the scalarizer to workshare array assignments. */
6012 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6013 ompws_flags |= OMPWS_SCALARIZER_WS;
6015 /* The assignment needs scalarization. */
6018 /* Find a non-scalar SS from the lhs. */
6019 while (lss_section != gfc_ss_terminator
6020 && lss_section->type != GFC_SS_SECTION)
6021 lss_section = lss_section->next;
6023 gcc_assert (lss_section != gfc_ss_terminator);
6025 /* Initialize the scalarizer. */
6026 gfc_init_loopinfo (&loop);
6029 rss = gfc_walk_expr (expr2);
6030 if (rss == gfc_ss_terminator)
6032 /* The rhs is scalar. Add a ss for the expression. */
6033 rss = gfc_get_ss ();
6034 rss->next = gfc_ss_terminator;
6035 rss->type = GFC_SS_SCALAR;
6038 /* Associate the SS with the loop. */
6039 gfc_add_ss_to_loop (&loop, lss);
6040 gfc_add_ss_to_loop (&loop, rss);
6042 /* Calculate the bounds of the scalarization. */
6043 gfc_conv_ss_startstride (&loop);
6044 /* Enable loop reversal. */
6045 for (n = 0; n < loop.dimen; n++)
6046 loop.reverse[n] = GFC_REVERSE_NOT_SET;
6047 /* Resolve any data dependencies in the statement. */
6048 gfc_conv_resolve_dependencies (&loop, lss, rss);
6049 /* Setup the scalarizing loops. */
6050 gfc_conv_loop_setup (&loop, &expr2->where);
6052 /* Setup the gfc_se structures. */
6053 gfc_copy_loopinfo_to_se (&lse, &loop);
6054 gfc_copy_loopinfo_to_se (&rse, &loop);
6057 gfc_mark_ss_chain_used (rss, 1);
6058 if (loop.temp_ss == NULL)
6061 gfc_mark_ss_chain_used (lss, 1);
6065 lse.ss = loop.temp_ss;
6066 gfc_mark_ss_chain_used (lss, 3);
6067 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6070 /* Start the scalarized loop body. */
6071 gfc_start_scalarized_body (&loop, &body);
6074 gfc_init_block (&body);
6076 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6078 /* Translate the expression. */
6079 gfc_conv_expr (&rse, expr2);
6081 /* Stabilize a string length for temporaries. */
6082 if (expr2->ts.type == BT_CHARACTER)
6083 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6085 string_length = NULL_TREE;
6089 gfc_conv_tmp_array_ref (&lse);
6090 if (expr2->ts.type == BT_CHARACTER)
6091 lse.string_length = string_length;
6094 gfc_conv_expr (&lse, expr1);
6096 /* Assignments of scalar derived types with allocatable components
6097 to arrays must be done with a deep copy and the rhs temporary
6098 must have its components deallocated afterwards. */
6099 scalar_to_array = (expr2->ts.type == BT_DERIVED
6100 && expr2->ts.u.derived->attr.alloc_comp
6101 && !expr_is_variable (expr2)
6102 && !gfc_is_constant_expr (expr2)
6103 && expr1->rank && !expr2->rank);
6104 if (scalar_to_array && dealloc)
6106 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6107 gfc_add_expr_to_block (&loop.post, tmp);
6110 /* For a deferred character length function, the function call must
6111 happen before the (re)allocation of the lhs, otherwise the character
6112 length of the result is not known. */
6113 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6114 || (expr2->expr_type == EXPR_COMPCALL)
6115 || (expr2->expr_type == EXPR_PPC))
6116 && expr2->ts.deferred);
6117 if (gfc_option.flag_realloc_lhs
6118 && expr2->ts.type == BT_CHARACTER
6119 && (def_clen_func || expr2->expr_type == EXPR_OP)
6120 && expr1->ts.deferred)
6121 gfc_add_block_to_block (&block, &rse.pre);
6123 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6124 l_is_temp || init_flag,
6125 expr_is_variable (expr2) || scalar_to_array,
6127 gfc_add_expr_to_block (&body, tmp);
6129 if (lss == gfc_ss_terminator)
6131 /* F2003: Add the code for reallocation on assignment. */
6132 if (gfc_option.flag_realloc_lhs
6133 && is_scalar_reallocatable_lhs (expr1))
6134 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6137 /* Use the scalar assignment as is. */
6138 gfc_add_block_to_block (&block, &body);
6142 gcc_assert (lse.ss == gfc_ss_terminator
6143 && rse.ss == gfc_ss_terminator);
6147 gfc_trans_scalarized_loop_boundary (&loop, &body);
6149 /* We need to copy the temporary to the actual lhs. */
6150 gfc_init_se (&lse, NULL);
6151 gfc_init_se (&rse, NULL);
6152 gfc_copy_loopinfo_to_se (&lse, &loop);
6153 gfc_copy_loopinfo_to_se (&rse, &loop);
6155 rse.ss = loop.temp_ss;
6158 gfc_conv_tmp_array_ref (&rse);
6159 gfc_conv_expr (&lse, expr1);
6161 gcc_assert (lse.ss == gfc_ss_terminator
6162 && rse.ss == gfc_ss_terminator);
6164 if (expr2->ts.type == BT_CHARACTER)
6165 rse.string_length = string_length;
6167 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6168 false, false, dealloc);
6169 gfc_add_expr_to_block (&body, tmp);
6172 /* F2003: Allocate or reallocate lhs of allocatable array. */
6173 if (gfc_option.flag_realloc_lhs
6174 && gfc_is_reallocatable_lhs (expr1)
6175 && !gfc_expr_attr (expr1).codimension
6176 && !gfc_is_coindexed (expr1))
6178 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6179 if (tmp != NULL_TREE)
6180 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6183 /* Generate the copying loops. */
6184 gfc_trans_scalarizing_loops (&loop, &body);
6186 /* Wrap the whole thing up. */
6187 gfc_add_block_to_block (&block, &loop.pre);
6188 gfc_add_block_to_block (&block, &loop.post);
6190 gfc_cleanup_loop (&loop);
6193 return gfc_finish_block (&block);
6197 /* Check whether EXPR is a copyable array. */
6200 copyable_array_p (gfc_expr * expr)
6202 if (expr->expr_type != EXPR_VARIABLE)
6205 /* First check it's an array. */
6206 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6209 if (!gfc_full_array_ref_p (expr->ref, NULL))
6212 /* Next check that it's of a simple enough type. */
6213 switch (expr->ts.type)
6225 return !expr->ts.u.derived->attr.alloc_comp;
6234 /* Translate an assignment. */
6237 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6242 /* Special case a single function returning an array. */
6243 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6245 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6250 /* Special case assigning an array to zero. */
6251 if (copyable_array_p (expr1)
6252 && is_zero_initializer_p (expr2))
6254 tmp = gfc_trans_zero_assign (expr1);
6259 /* Special case copying one array to another. */
6260 if (copyable_array_p (expr1)
6261 && copyable_array_p (expr2)
6262 && gfc_compare_types (&expr1->ts, &expr2->ts)
6263 && !gfc_check_dependency (expr1, expr2, 0))
6265 tmp = gfc_trans_array_copy (expr1, expr2);
6270 /* Special case initializing an array from a constant array constructor. */
6271 if (copyable_array_p (expr1)
6272 && expr2->expr_type == EXPR_ARRAY
6273 && gfc_compare_types (&expr1->ts, &expr2->ts))
6275 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6280 /* Fallback to the scalarizer to generate explicit loops. */
6281 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6285 gfc_trans_init_assign (gfc_code * code)
6287 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6291 gfc_trans_assign (gfc_code * code)
6293 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6297 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6298 A MEMCPY is needed to copy the full data from the default initializer
6299 of the dynamic type. */
6302 gfc_trans_class_init_assign (gfc_code *code)
6306 gfc_se dst,src,memsz;
6307 gfc_expr *lhs,*rhs,*sz;
6309 gfc_start_block (&block);
6311 lhs = gfc_copy_expr (code->expr1);
6312 gfc_add_data_component (lhs);
6314 rhs = gfc_copy_expr (code->expr1);
6315 gfc_add_vptr_component (rhs);
6317 /* Make sure that the component backend_decls have been built, which
6318 will not have happened if the derived types concerned have not
6320 gfc_get_derived_type (rhs->ts.u.derived);
6321 gfc_add_def_init_component (rhs);
6323 sz = gfc_copy_expr (code->expr1);
6324 gfc_add_vptr_component (sz);
6325 gfc_add_size_component (sz);
6327 gfc_init_se (&dst, NULL);
6328 gfc_init_se (&src, NULL);
6329 gfc_init_se (&memsz, NULL);
6330 gfc_conv_expr (&dst, lhs);
6331 gfc_conv_expr (&src, rhs);
6332 gfc_conv_expr (&memsz, sz);
6333 gfc_add_block_to_block (&block, &src.pre);
6334 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6335 gfc_add_expr_to_block (&block, tmp);
6337 return gfc_finish_block (&block);
6341 /* Translate an assignment to a CLASS object
6342 (pointer or ordinary assignment). */
6345 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6352 gfc_start_block (&block);
6354 if (expr2->ts.type != BT_CLASS)
6356 /* Insert an additional assignment which sets the '_vptr' field. */
6357 gfc_symbol *vtab = NULL;
6360 lhs = gfc_copy_expr (expr1);
6361 gfc_add_vptr_component (lhs);
6363 if (expr2->ts.type == BT_DERIVED)
6364 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6365 else if (expr2->expr_type == EXPR_NULL)
6366 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6369 rhs = gfc_get_expr ();
6370 rhs->expr_type = EXPR_VARIABLE;
6371 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6375 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6376 gfc_add_expr_to_block (&block, tmp);
6378 gfc_free_expr (lhs);
6379 gfc_free_expr (rhs);
6382 /* Do the actual CLASS assignment. */
6383 if (expr2->ts.type == BT_CLASS)
6386 gfc_add_data_component (expr1);
6388 if (op == EXEC_ASSIGN)
6389 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6390 else if (op == EXEC_POINTER_ASSIGN)
6391 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6395 gfc_add_expr_to_block (&block, tmp);
6397 return gfc_finish_block (&block);