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 /* Return for an expression the backend decl of the coarray. */
267 get_tree_for_caf_expr (gfc_expr *expr)
269 tree caf_decl = NULL_TREE;
272 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
273 if (expr->symtree->n.sym->attr.codimension)
274 caf_decl = expr->symtree->n.sym->backend_decl;
276 for (ref = expr->ref; ref; ref = ref->next)
277 if (ref->type == REF_COMPONENT)
279 gfc_component *comp = ref->u.c.component;
280 if (comp->attr.pointer || comp->attr.allocatable)
281 caf_decl = NULL_TREE;
282 if (comp->attr.codimension)
283 caf_decl = comp->backend_decl;
286 gcc_assert (caf_decl != NULL_TREE);
291 /* For each character array constructor subexpression without a ts.u.cl->length,
292 replace it by its first element (if there aren't any elements, the length
293 should already be set to zero). */
296 flatten_array_ctors_without_strlen (gfc_expr* e)
298 gfc_actual_arglist* arg;
304 switch (e->expr_type)
308 flatten_array_ctors_without_strlen (e->value.op.op1);
309 flatten_array_ctors_without_strlen (e->value.op.op2);
313 /* TODO: Implement as with EXPR_FUNCTION when needed. */
317 for (arg = e->value.function.actual; arg; arg = arg->next)
318 flatten_array_ctors_without_strlen (arg->expr);
323 /* We've found what we're looking for. */
324 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
329 gcc_assert (e->value.constructor);
331 c = gfc_constructor_first (e->value.constructor);
335 flatten_array_ctors_without_strlen (new_expr);
336 gfc_replace_expr (e, new_expr);
340 /* Otherwise, fall through to handle constructor elements. */
342 for (c = gfc_constructor_first (e->value.constructor);
343 c; c = gfc_constructor_next (c))
344 flatten_array_ctors_without_strlen (c->expr);
354 /* Generate code to initialize a string length variable. Returns the
355 value. For array constructors, cl->length might be NULL and in this case,
356 the first element of the constructor is needed. expr is the original
357 expression so we can access it but can be NULL if this is not needed. */
360 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
364 gfc_init_se (&se, NULL);
368 && TREE_CODE (cl->backend_decl) == VAR_DECL)
371 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
372 "flatten" array constructors by taking their first element; all elements
373 should be the same length or a cl->length should be present. */
378 expr_flat = gfc_copy_expr (expr);
379 flatten_array_ctors_without_strlen (expr_flat);
380 gfc_resolve_expr (expr_flat);
382 gfc_conv_expr (&se, expr_flat);
383 gfc_add_block_to_block (pblock, &se.pre);
384 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
386 gfc_free_expr (expr_flat);
390 /* Convert cl->length. */
392 gcc_assert (cl->length);
394 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
395 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
396 se.expr, build_int_cst (gfc_charlen_type_node, 0));
397 gfc_add_block_to_block (pblock, &se.pre);
399 if (cl->backend_decl)
400 gfc_add_modify (pblock, cl->backend_decl, se.expr);
402 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
407 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
408 const char *name, locus *where)
417 type = gfc_get_character_type (kind, ref->u.ss.length);
418 type = build_pointer_type (type);
420 gfc_init_se (&start, se);
421 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
422 gfc_add_block_to_block (&se->pre, &start.pre);
424 if (integer_onep (start.expr))
425 gfc_conv_string_parameter (se);
430 /* Avoid multiple evaluation of substring start. */
431 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
432 start.expr = gfc_evaluate_now (start.expr, &se->pre);
434 /* Change the start of the string. */
435 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
438 tmp = build_fold_indirect_ref_loc (input_location,
440 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
441 se->expr = gfc_build_addr_expr (type, tmp);
444 /* Length = end + 1 - start. */
445 gfc_init_se (&end, se);
446 if (ref->u.ss.end == NULL)
447 end.expr = se->string_length;
450 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
451 gfc_add_block_to_block (&se->pre, &end.pre);
455 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
456 end.expr = gfc_evaluate_now (end.expr, &se->pre);
458 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
460 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
461 boolean_type_node, start.expr,
464 /* Check lower bound. */
465 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
467 build_int_cst (gfc_charlen_type_node, 1));
468 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
469 boolean_type_node, nonempty, fault);
471 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
472 "is less than one", name);
474 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
476 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
477 fold_convert (long_integer_type_node,
481 /* Check upper bound. */
482 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
483 end.expr, se->string_length);
484 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
485 boolean_type_node, nonempty, fault);
487 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
488 "exceeds string length (%%ld)", name);
490 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
491 "exceeds string length (%%ld)");
492 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
493 fold_convert (long_integer_type_node, end.expr),
494 fold_convert (long_integer_type_node,
499 /* If the start and end expressions are equal, the length is one. */
501 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
502 tmp = build_int_cst (gfc_charlen_type_node, 1);
505 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
506 end.expr, start.expr);
507 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
508 build_int_cst (gfc_charlen_type_node, 1), tmp);
509 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
510 tmp, build_int_cst (gfc_charlen_type_node, 0));
513 se->string_length = tmp;
517 /* Convert a derived type component reference. */
520 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
527 c = ref->u.c.component;
529 gcc_assert (c->backend_decl);
531 field = c->backend_decl;
532 gcc_assert (TREE_CODE (field) == FIELD_DECL);
535 /* Components can correspond to fields of different containing
536 types, as components are created without context, whereas
537 a concrete use of a component has the type of decl as context.
538 So, if the type doesn't match, we search the corresponding
539 FIELD_DECL in the parent type. To not waste too much time
540 we cache this result in norestrict_decl. */
542 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
544 tree f2 = c->norestrict_decl;
545 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
546 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
547 if (TREE_CODE (f2) == FIELD_DECL
548 && DECL_NAME (f2) == DECL_NAME (field))
551 c->norestrict_decl = f2;
554 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
555 decl, field, NULL_TREE);
559 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
561 tmp = c->ts.u.cl->backend_decl;
562 /* Components must always be constant length. */
563 gcc_assert (tmp && INTEGER_CST_P (tmp));
564 se->string_length = tmp;
567 if (((c->attr.pointer || c->attr.allocatable)
568 && (!c->attr.dimension && !c->attr.codimension)
569 && c->ts.type != BT_CHARACTER)
570 || c->attr.proc_pointer)
571 se->expr = build_fold_indirect_ref_loc (input_location,
576 /* This function deals with component references to components of the
577 parent type for derived type extensons. */
579 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
587 c = ref->u.c.component;
589 /* Return if the component is not in the parent type. */
590 for (cmp = dt->components; cmp; cmp = cmp->next)
591 if (strcmp (c->name, cmp->name) == 0)
594 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
595 parent.type = REF_COMPONENT;
598 parent.u.c.component = dt->components;
600 if (dt->backend_decl == NULL)
601 gfc_get_derived_type (dt);
603 /* Build the reference and call self. */
604 gfc_conv_component_ref (se, &parent);
605 parent.u.c.sym = dt->components->ts.u.derived;
606 parent.u.c.component = c;
607 conv_parent_component_references (se, &parent);
610 /* Return the contents of a variable. Also handles reference/pointer
611 variables (all Fortran pointer references are implicit). */
614 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
618 tree parent_decl = NULL_TREE;
621 bool alternate_entry;
624 sym = expr->symtree->n.sym;
627 /* Check that something hasn't gone horribly wrong. */
628 gcc_assert (se->ss != gfc_ss_terminator);
629 gcc_assert (se->ss->expr == expr);
631 /* A scalarized term. We already know the descriptor. */
632 se->expr = se->ss->data.info.descriptor;
633 se->string_length = se->ss->string_length;
634 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
635 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
640 tree se_expr = NULL_TREE;
642 se->expr = gfc_get_symbol_decl (sym);
644 /* Deal with references to a parent results or entries by storing
645 the current_function_decl and moving to the parent_decl. */
646 return_value = sym->attr.function && sym->result == sym;
647 alternate_entry = sym->attr.function && sym->attr.entry
648 && sym->result == sym;
649 entry_master = sym->attr.result
650 && sym->ns->proc_name->attr.entry_master
651 && !gfc_return_by_reference (sym->ns->proc_name);
652 if (current_function_decl)
653 parent_decl = DECL_CONTEXT (current_function_decl);
655 if ((se->expr == parent_decl && return_value)
656 || (sym->ns && sym->ns->proc_name
658 && sym->ns->proc_name->backend_decl == parent_decl
659 && (alternate_entry || entry_master)))
664 /* Special case for assigning the return value of a function.
665 Self recursive functions must have an explicit return value. */
666 if (return_value && (se->expr == current_function_decl || parent_flag))
667 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
669 /* Similarly for alternate entry points. */
670 else if (alternate_entry
671 && (sym->ns->proc_name->backend_decl == current_function_decl
674 gfc_entry_list *el = NULL;
676 for (el = sym->ns->entries; el; el = el->next)
679 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
684 else if (entry_master
685 && (sym->ns->proc_name->backend_decl == current_function_decl
687 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
692 /* Procedure actual arguments. */
693 else if (sym->attr.flavor == FL_PROCEDURE
694 && se->expr != current_function_decl)
696 if (!sym->attr.dummy && !sym->attr.proc_pointer)
698 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
699 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
705 /* Dereference the expression, where needed. Since characters
706 are entirely different from other types, they are treated
708 if (sym->ts.type == BT_CHARACTER)
710 /* Dereference character pointer dummy arguments
712 if ((sym->attr.pointer || sym->attr.allocatable)
714 || sym->attr.function
715 || sym->attr.result))
716 se->expr = build_fold_indirect_ref_loc (input_location,
720 else if (!sym->attr.value)
722 /* Dereference non-character scalar dummy arguments. */
723 if (sym->attr.dummy && !sym->attr.dimension
724 && !(sym->attr.codimension && sym->attr.allocatable))
725 se->expr = build_fold_indirect_ref_loc (input_location,
728 /* Dereference scalar hidden result. */
729 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
730 && (sym->attr.function || sym->attr.result)
731 && !sym->attr.dimension && !sym->attr.pointer
732 && !sym->attr.always_explicit)
733 se->expr = build_fold_indirect_ref_loc (input_location,
736 /* Dereference non-character pointer variables.
737 These must be dummies, results, or scalars. */
738 if ((sym->attr.pointer || sym->attr.allocatable
739 || gfc_is_associate_pointer (sym))
741 || sym->attr.function
743 || (!sym->attr.dimension
744 && (!sym->attr.codimension || !sym->attr.allocatable))))
745 se->expr = build_fold_indirect_ref_loc (input_location,
752 /* For character variables, also get the length. */
753 if (sym->ts.type == BT_CHARACTER)
755 /* If the character length of an entry isn't set, get the length from
756 the master function instead. */
757 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
758 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
760 se->string_length = sym->ts.u.cl->backend_decl;
761 gcc_assert (se->string_length);
769 /* Return the descriptor if that's what we want and this is an array
770 section reference. */
771 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
773 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
774 /* Return the descriptor for array pointers and allocations. */
776 && ref->next == NULL && (se->descriptor_only))
779 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
780 /* Return a pointer to an element. */
784 if (ref->u.c.sym->attr.extension)
785 conv_parent_component_references (se, ref);
787 gfc_conv_component_ref (se, ref);
791 gfc_conv_substring (se, ref, expr->ts.kind,
792 expr->symtree->name, &expr->where);
801 /* Pointer assignment, allocation or pass by reference. Arrays are handled
803 if (se->want_pointer)
805 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
806 gfc_conv_string_parameter (se);
808 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
813 /* Unary ops are easy... Or they would be if ! was a valid op. */
816 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
821 gcc_assert (expr->ts.type != BT_CHARACTER);
822 /* Initialize the operand. */
823 gfc_init_se (&operand, se);
824 gfc_conv_expr_val (&operand, expr->value.op.op1);
825 gfc_add_block_to_block (&se->pre, &operand.pre);
827 type = gfc_typenode_for_spec (&expr->ts);
829 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
830 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
831 All other unary operators have an equivalent GIMPLE unary operator. */
832 if (code == TRUTH_NOT_EXPR)
833 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
834 build_int_cst (type, 0));
836 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
840 /* Expand power operator to optimal multiplications when a value is raised
841 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
842 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
843 Programming", 3rd Edition, 1998. */
845 /* This code is mostly duplicated from expand_powi in the backend.
846 We establish the "optimal power tree" lookup table with the defined size.
847 The items in the table are the exponents used to calculate the index
848 exponents. Any integer n less than the value can get an "addition chain",
849 with the first node being one. */
850 #define POWI_TABLE_SIZE 256
852 /* The table is from builtins.c. */
853 static const unsigned char powi_table[POWI_TABLE_SIZE] =
855 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
856 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
857 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
858 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
859 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
860 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
861 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
862 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
863 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
864 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
865 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
866 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
867 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
868 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
869 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
870 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
871 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
872 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
873 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
874 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
875 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
876 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
877 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
878 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
879 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
880 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
881 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
882 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
883 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
884 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
885 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
886 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
889 /* If n is larger than lookup table's max index, we use the "window
891 #define POWI_WINDOW_SIZE 3
893 /* Recursive function to expand the power operator. The temporary
894 values are put in tmpvar. The function returns tmpvar[1] ** n. */
896 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
903 if (n < POWI_TABLE_SIZE)
908 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
909 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
913 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
914 op0 = gfc_conv_powi (se, n - digit, tmpvar);
915 op1 = gfc_conv_powi (se, digit, tmpvar);
919 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
923 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
924 tmp = gfc_evaluate_now (tmp, &se->pre);
926 if (n < POWI_TABLE_SIZE)
933 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
934 return 1. Else return 0 and a call to runtime library functions
935 will have to be built. */
937 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
942 tree vartmp[POWI_TABLE_SIZE];
944 unsigned HOST_WIDE_INT n;
947 /* If exponent is too large, we won't expand it anyway, so don't bother
948 with large integer values. */
949 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
952 m = double_int_to_shwi (TREE_INT_CST (rhs));
953 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
954 of the asymmetric range of the integer type. */
955 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
957 type = TREE_TYPE (lhs);
958 sgn = tree_int_cst_sgn (rhs);
960 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
961 || optimize_size) && (m > 2 || m < -1))
967 se->expr = gfc_build_const (type, integer_one_node);
971 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
972 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
974 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
975 lhs, build_int_cst (TREE_TYPE (lhs), -1));
976 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
977 lhs, build_int_cst (TREE_TYPE (lhs), 1));
980 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
983 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
984 boolean_type_node, tmp, cond);
985 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
986 tmp, build_int_cst (type, 1),
987 build_int_cst (type, 0));
991 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
992 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
993 build_int_cst (type, -1),
994 build_int_cst (type, 0));
995 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
996 cond, build_int_cst (type, 1), tmp);
1000 memset (vartmp, 0, sizeof (vartmp));
1004 tmp = gfc_build_const (type, integer_one_node);
1005 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1009 se->expr = gfc_conv_powi (se, n, vartmp);
1015 /* Power op (**). Constant integer exponent has special handling. */
1018 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1020 tree gfc_int4_type_node;
1023 int res_ikind_1, res_ikind_2;
1028 gfc_init_se (&lse, se);
1029 gfc_conv_expr_val (&lse, expr->value.op.op1);
1030 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1031 gfc_add_block_to_block (&se->pre, &lse.pre);
1033 gfc_init_se (&rse, se);
1034 gfc_conv_expr_val (&rse, expr->value.op.op2);
1035 gfc_add_block_to_block (&se->pre, &rse.pre);
1037 if (expr->value.op.op2->ts.type == BT_INTEGER
1038 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1039 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1042 gfc_int4_type_node = gfc_get_int_type (4);
1044 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1045 library routine. But in the end, we have to convert the result back
1046 if this case applies -- with res_ikind_K, we keep track whether operand K
1047 falls into this case. */
1051 kind = expr->value.op.op1->ts.kind;
1052 switch (expr->value.op.op2->ts.type)
1055 ikind = expr->value.op.op2->ts.kind;
1060 rse.expr = convert (gfc_int4_type_node, rse.expr);
1061 res_ikind_2 = ikind;
1083 if (expr->value.op.op1->ts.type == BT_INTEGER)
1085 lse.expr = convert (gfc_int4_type_node, lse.expr);
1112 switch (expr->value.op.op1->ts.type)
1115 if (kind == 3) /* Case 16 was not handled properly above. */
1117 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1121 /* Use builtins for real ** int4. */
1127 fndecl = built_in_decls[BUILT_IN_POWIF];
1131 fndecl = built_in_decls[BUILT_IN_POWI];
1135 fndecl = built_in_decls[BUILT_IN_POWIL];
1139 /* Use the __builtin_powil() only if real(kind=16) is
1140 actually the C long double type. */
1141 if (!gfc_real16_is_float128)
1142 fndecl = built_in_decls[BUILT_IN_POWIL];
1150 /* If we don't have a good builtin for this, go for the
1151 library function. */
1153 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1157 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1166 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1170 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1178 se->expr = build_call_expr_loc (input_location,
1179 fndecl, 2, lse.expr, rse.expr);
1181 /* Convert the result back if it is of wrong integer kind. */
1182 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1184 /* We want the maximum of both operand kinds as result. */
1185 if (res_ikind_1 < res_ikind_2)
1186 res_ikind_1 = res_ikind_2;
1187 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1192 /* Generate code to allocate a string temporary. */
1195 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1200 if (gfc_can_put_var_on_stack (len))
1202 /* Create a temporary variable to hold the result. */
1203 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1204 gfc_charlen_type_node, len,
1205 build_int_cst (gfc_charlen_type_node, 1));
1206 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1208 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1209 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1211 tmp = build_array_type (TREE_TYPE (type), tmp);
1213 var = gfc_create_var (tmp, "str");
1214 var = gfc_build_addr_expr (type, var);
1218 /* Allocate a temporary to hold the result. */
1219 var = gfc_create_var (type, "pstr");
1220 tmp = gfc_call_malloc (&se->pre, type,
1221 fold_build2_loc (input_location, MULT_EXPR,
1222 TREE_TYPE (len), len,
1223 fold_convert (TREE_TYPE (len),
1224 TYPE_SIZE (type))));
1225 gfc_add_modify (&se->pre, var, tmp);
1227 /* Free the temporary afterwards. */
1228 tmp = gfc_call_free (convert (pvoid_type_node, var));
1229 gfc_add_expr_to_block (&se->post, tmp);
1236 /* Handle a string concatenation operation. A temporary will be allocated to
1240 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1243 tree len, type, var, tmp, fndecl;
1245 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1246 && expr->value.op.op2->ts.type == BT_CHARACTER);
1247 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1249 gfc_init_se (&lse, se);
1250 gfc_conv_expr (&lse, expr->value.op.op1);
1251 gfc_conv_string_parameter (&lse);
1252 gfc_init_se (&rse, se);
1253 gfc_conv_expr (&rse, expr->value.op.op2);
1254 gfc_conv_string_parameter (&rse);
1256 gfc_add_block_to_block (&se->pre, &lse.pre);
1257 gfc_add_block_to_block (&se->pre, &rse.pre);
1259 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1260 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1261 if (len == NULL_TREE)
1263 len = fold_build2_loc (input_location, PLUS_EXPR,
1264 TREE_TYPE (lse.string_length),
1265 lse.string_length, rse.string_length);
1268 type = build_pointer_type (type);
1270 var = gfc_conv_string_tmp (se, type, len);
1272 /* Do the actual concatenation. */
1273 if (expr->ts.kind == 1)
1274 fndecl = gfor_fndecl_concat_string;
1275 else if (expr->ts.kind == 4)
1276 fndecl = gfor_fndecl_concat_string_char4;
1280 tmp = build_call_expr_loc (input_location,
1281 fndecl, 6, len, var, lse.string_length, lse.expr,
1282 rse.string_length, rse.expr);
1283 gfc_add_expr_to_block (&se->pre, tmp);
1285 /* Add the cleanup for the operands. */
1286 gfc_add_block_to_block (&se->pre, &rse.post);
1287 gfc_add_block_to_block (&se->pre, &lse.post);
1290 se->string_length = len;
1293 /* Translates an op expression. Common (binary) cases are handled by this
1294 function, others are passed on. Recursion is used in either case.
1295 We use the fact that (op1.ts == op2.ts) (except for the power
1297 Operators need no special handling for scalarized expressions as long as
1298 they call gfc_conv_simple_val to get their operands.
1299 Character strings get special handling. */
1302 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1304 enum tree_code code;
1313 switch (expr->value.op.op)
1315 case INTRINSIC_PARENTHESES:
1316 if ((expr->ts.type == BT_REAL
1317 || expr->ts.type == BT_COMPLEX)
1318 && gfc_option.flag_protect_parens)
1320 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1321 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1326 case INTRINSIC_UPLUS:
1327 gfc_conv_expr (se, expr->value.op.op1);
1330 case INTRINSIC_UMINUS:
1331 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1335 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1338 case INTRINSIC_PLUS:
1342 case INTRINSIC_MINUS:
1346 case INTRINSIC_TIMES:
1350 case INTRINSIC_DIVIDE:
1351 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1352 an integer, we must round towards zero, so we use a
1354 if (expr->ts.type == BT_INTEGER)
1355 code = TRUNC_DIV_EXPR;
1360 case INTRINSIC_POWER:
1361 gfc_conv_power_op (se, expr);
1364 case INTRINSIC_CONCAT:
1365 gfc_conv_concat_op (se, expr);
1369 code = TRUTH_ANDIF_EXPR;
1374 code = TRUTH_ORIF_EXPR;
1378 /* EQV and NEQV only work on logicals, but since we represent them
1379 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1381 case INTRINSIC_EQ_OS:
1389 case INTRINSIC_NE_OS:
1390 case INTRINSIC_NEQV:
1397 case INTRINSIC_GT_OS:
1404 case INTRINSIC_GE_OS:
1411 case INTRINSIC_LT_OS:
1418 case INTRINSIC_LE_OS:
1424 case INTRINSIC_USER:
1425 case INTRINSIC_ASSIGN:
1426 /* These should be converted into function calls by the frontend. */
1430 fatal_error ("Unknown intrinsic op");
1434 /* The only exception to this is **, which is handled separately anyway. */
1435 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1437 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1441 gfc_init_se (&lse, se);
1442 gfc_conv_expr (&lse, expr->value.op.op1);
1443 gfc_add_block_to_block (&se->pre, &lse.pre);
1446 gfc_init_se (&rse, se);
1447 gfc_conv_expr (&rse, expr->value.op.op2);
1448 gfc_add_block_to_block (&se->pre, &rse.pre);
1452 gfc_conv_string_parameter (&lse);
1453 gfc_conv_string_parameter (&rse);
1455 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1456 rse.string_length, rse.expr,
1457 expr->value.op.op1->ts.kind,
1459 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1460 gfc_add_block_to_block (&lse.post, &rse.post);
1463 type = gfc_typenode_for_spec (&expr->ts);
1467 /* The result of logical ops is always boolean_type_node. */
1468 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1469 lse.expr, rse.expr);
1470 se->expr = convert (type, tmp);
1473 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1475 /* Add the post blocks. */
1476 gfc_add_block_to_block (&se->post, &rse.post);
1477 gfc_add_block_to_block (&se->post, &lse.post);
1480 /* If a string's length is one, we convert it to a single character. */
1483 gfc_string_to_single_character (tree len, tree str, int kind)
1486 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1487 || !POINTER_TYPE_P (TREE_TYPE (str)))
1490 if (TREE_INT_CST_LOW (len) == 1)
1492 str = fold_convert (gfc_get_pchar_type (kind), str);
1493 return build_fold_indirect_ref_loc (input_location, str);
1497 && TREE_CODE (str) == ADDR_EXPR
1498 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1499 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1500 && array_ref_low_bound (TREE_OPERAND (str, 0))
1501 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1502 && TREE_INT_CST_LOW (len) > 1
1503 && TREE_INT_CST_LOW (len)
1504 == (unsigned HOST_WIDE_INT)
1505 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1507 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1508 ret = build_fold_indirect_ref_loc (input_location, ret);
1509 if (TREE_CODE (ret) == INTEGER_CST)
1511 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1512 int i, length = TREE_STRING_LENGTH (string_cst);
1513 const char *ptr = TREE_STRING_POINTER (string_cst);
1515 for (i = 1; i < length; i++)
1528 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1531 if (sym->backend_decl)
1533 /* This becomes the nominal_type in
1534 function.c:assign_parm_find_data_types. */
1535 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1536 /* This becomes the passed_type in
1537 function.c:assign_parm_find_data_types. C promotes char to
1538 integer for argument passing. */
1539 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1541 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1546 /* If we have a constant character expression, make it into an
1548 if ((*expr)->expr_type == EXPR_CONSTANT)
1553 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1554 (int)(*expr)->value.character.string[0]);
1555 if ((*expr)->ts.kind != gfc_c_int_kind)
1557 /* The expr needs to be compatible with a C int. If the
1558 conversion fails, then the 2 causes an ICE. */
1559 ts.type = BT_INTEGER;
1560 ts.kind = gfc_c_int_kind;
1561 gfc_convert_type (*expr, &ts, 2);
1564 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1566 if ((*expr)->ref == NULL)
1568 se->expr = gfc_string_to_single_character
1569 (build_int_cst (integer_type_node, 1),
1570 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1572 ((*expr)->symtree->n.sym)),
1577 gfc_conv_variable (se, *expr);
1578 se->expr = gfc_string_to_single_character
1579 (build_int_cst (integer_type_node, 1),
1580 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1588 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1589 if STR is a string literal, otherwise return -1. */
1592 gfc_optimize_len_trim (tree len, tree str, int kind)
1595 && TREE_CODE (str) == ADDR_EXPR
1596 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1597 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1598 && array_ref_low_bound (TREE_OPERAND (str, 0))
1599 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1600 && TREE_INT_CST_LOW (len) >= 1
1601 && TREE_INT_CST_LOW (len)
1602 == (unsigned HOST_WIDE_INT)
1603 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1605 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1606 folded = build_fold_indirect_ref_loc (input_location, folded);
1607 if (TREE_CODE (folded) == INTEGER_CST)
1609 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1610 int length = TREE_STRING_LENGTH (string_cst);
1611 const char *ptr = TREE_STRING_POINTER (string_cst);
1613 for (; length > 0; length--)
1614 if (ptr[length - 1] != ' ')
1623 /* Compare two strings. If they are all single characters, the result is the
1624 subtraction of them. Otherwise, we build a library call. */
1627 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1628 enum tree_code code)
1634 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1635 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1637 sc1 = gfc_string_to_single_character (len1, str1, kind);
1638 sc2 = gfc_string_to_single_character (len2, str2, kind);
1640 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1642 /* Deal with single character specially. */
1643 sc1 = fold_convert (integer_type_node, sc1);
1644 sc2 = fold_convert (integer_type_node, sc2);
1645 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1649 if ((code == EQ_EXPR || code == NE_EXPR)
1651 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1653 /* If one string is a string literal with LEN_TRIM longer
1654 than the length of the second string, the strings
1656 int len = gfc_optimize_len_trim (len1, str1, kind);
1657 if (len > 0 && compare_tree_int (len2, len) < 0)
1658 return integer_one_node;
1659 len = gfc_optimize_len_trim (len2, str2, kind);
1660 if (len > 0 && compare_tree_int (len1, len) < 0)
1661 return integer_one_node;
1664 /* Build a call for the comparison. */
1666 fndecl = gfor_fndecl_compare_string;
1668 fndecl = gfor_fndecl_compare_string_char4;
1672 return build_call_expr_loc (input_location, fndecl, 4,
1673 len1, str1, len2, str2);
1677 /* Return the backend_decl for a procedure pointer component. */
1680 get_proc_ptr_comp (gfc_expr *e)
1686 gfc_init_se (&comp_se, NULL);
1687 e2 = gfc_copy_expr (e);
1688 /* We have to restore the expr type later so that gfc_free_expr frees
1689 the exact same thing that was allocated.
1690 TODO: This is ugly. */
1691 old_type = e2->expr_type;
1692 e2->expr_type = EXPR_VARIABLE;
1693 gfc_conv_expr (&comp_se, e2);
1694 e2->expr_type = old_type;
1696 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1701 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1705 if (gfc_is_proc_ptr_comp (expr, NULL))
1706 tmp = get_proc_ptr_comp (expr);
1707 else if (sym->attr.dummy)
1709 tmp = gfc_get_symbol_decl (sym);
1710 if (sym->attr.proc_pointer)
1711 tmp = build_fold_indirect_ref_loc (input_location,
1713 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1714 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1718 if (!sym->backend_decl)
1719 sym->backend_decl = gfc_get_extern_function_decl (sym);
1721 tmp = sym->backend_decl;
1723 if (sym->attr.cray_pointee)
1725 /* TODO - make the cray pointee a pointer to a procedure,
1726 assign the pointer to it and use it for the call. This
1728 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1729 gfc_get_symbol_decl (sym->cp_pointer));
1730 tmp = gfc_evaluate_now (tmp, &se->pre);
1733 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1735 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1736 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1743 /* Initialize MAPPING. */
1746 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1748 mapping->syms = NULL;
1749 mapping->charlens = NULL;
1753 /* Free all memory held by MAPPING (but not MAPPING itself). */
1756 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1758 gfc_interface_sym_mapping *sym;
1759 gfc_interface_sym_mapping *nextsym;
1761 gfc_charlen *nextcl;
1763 for (sym = mapping->syms; sym; sym = nextsym)
1765 nextsym = sym->next;
1766 sym->new_sym->n.sym->formal = NULL;
1767 gfc_free_symbol (sym->new_sym->n.sym);
1768 gfc_free_expr (sym->expr);
1769 free (sym->new_sym);
1772 for (cl = mapping->charlens; cl; cl = nextcl)
1775 gfc_free_expr (cl->length);
1781 /* Return a copy of gfc_charlen CL. Add the returned structure to
1782 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1784 static gfc_charlen *
1785 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1788 gfc_charlen *new_charlen;
1790 new_charlen = gfc_get_charlen ();
1791 new_charlen->next = mapping->charlens;
1792 new_charlen->length = gfc_copy_expr (cl->length);
1794 mapping->charlens = new_charlen;
1799 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1800 array variable that can be used as the actual argument for dummy
1801 argument SYM. Add any initialization code to BLOCK. PACKED is as
1802 for gfc_get_nodesc_array_type and DATA points to the first element
1803 in the passed array. */
1806 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1807 gfc_packed packed, tree data)
1812 type = gfc_typenode_for_spec (&sym->ts);
1813 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1814 !sym->attr.target && !sym->attr.pointer
1815 && !sym->attr.proc_pointer);
1817 var = gfc_create_var (type, "ifm");
1818 gfc_add_modify (block, var, fold_convert (type, data));
1824 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1825 and offset of descriptorless array type TYPE given that it has the same
1826 size as DESC. Add any set-up code to BLOCK. */
1829 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1836 offset = gfc_index_zero_node;
1837 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1839 dim = gfc_rank_cst[n];
1840 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1841 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1843 GFC_TYPE_ARRAY_LBOUND (type, n)
1844 = gfc_conv_descriptor_lbound_get (desc, dim);
1845 GFC_TYPE_ARRAY_UBOUND (type, n)
1846 = gfc_conv_descriptor_ubound_get (desc, dim);
1848 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1850 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1851 gfc_array_index_type,
1852 gfc_conv_descriptor_ubound_get (desc, dim),
1853 gfc_conv_descriptor_lbound_get (desc, dim));
1854 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1855 gfc_array_index_type,
1856 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1857 tmp = gfc_evaluate_now (tmp, block);
1858 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1860 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1861 GFC_TYPE_ARRAY_LBOUND (type, n),
1862 GFC_TYPE_ARRAY_STRIDE (type, n));
1863 offset = fold_build2_loc (input_location, MINUS_EXPR,
1864 gfc_array_index_type, offset, tmp);
1866 offset = gfc_evaluate_now (offset, block);
1867 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1871 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1872 in SE. The caller may still use se->expr and se->string_length after
1873 calling this function. */
1876 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1877 gfc_symbol * sym, gfc_se * se,
1880 gfc_interface_sym_mapping *sm;
1884 gfc_symbol *new_sym;
1886 gfc_symtree *new_symtree;
1888 /* Create a new symbol to represent the actual argument. */
1889 new_sym = gfc_new_symbol (sym->name, NULL);
1890 new_sym->ts = sym->ts;
1891 new_sym->as = gfc_copy_array_spec (sym->as);
1892 new_sym->attr.referenced = 1;
1893 new_sym->attr.dimension = sym->attr.dimension;
1894 new_sym->attr.contiguous = sym->attr.contiguous;
1895 new_sym->attr.codimension = sym->attr.codimension;
1896 new_sym->attr.pointer = sym->attr.pointer;
1897 new_sym->attr.allocatable = sym->attr.allocatable;
1898 new_sym->attr.flavor = sym->attr.flavor;
1899 new_sym->attr.function = sym->attr.function;
1901 /* Ensure that the interface is available and that
1902 descriptors are passed for array actual arguments. */
1903 if (sym->attr.flavor == FL_PROCEDURE)
1905 new_sym->formal = expr->symtree->n.sym->formal;
1906 new_sym->attr.always_explicit
1907 = expr->symtree->n.sym->attr.always_explicit;
1910 /* Create a fake symtree for it. */
1912 new_symtree = gfc_new_symtree (&root, sym->name);
1913 new_symtree->n.sym = new_sym;
1914 gcc_assert (new_symtree == root);
1916 /* Create a dummy->actual mapping. */
1917 sm = XCNEW (gfc_interface_sym_mapping);
1918 sm->next = mapping->syms;
1920 sm->new_sym = new_symtree;
1921 sm->expr = gfc_copy_expr (expr);
1924 /* Stabilize the argument's value. */
1925 if (!sym->attr.function && se)
1926 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1928 if (sym->ts.type == BT_CHARACTER)
1930 /* Create a copy of the dummy argument's length. */
1931 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1932 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1934 /* If the length is specified as "*", record the length that
1935 the caller is passing. We should use the callee's length
1936 in all other cases. */
1937 if (!new_sym->ts.u.cl->length && se)
1939 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1940 new_sym->ts.u.cl->backend_decl = se->string_length;
1947 /* Use the passed value as-is if the argument is a function. */
1948 if (sym->attr.flavor == FL_PROCEDURE)
1951 /* If the argument is either a string or a pointer to a string,
1952 convert it to a boundless character type. */
1953 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1955 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1956 tmp = build_pointer_type (tmp);
1957 if (sym->attr.pointer)
1958 value = build_fold_indirect_ref_loc (input_location,
1962 value = fold_convert (tmp, value);
1965 /* If the argument is a scalar, a pointer to an array or an allocatable,
1967 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1968 value = build_fold_indirect_ref_loc (input_location,
1971 /* For character(*), use the actual argument's descriptor. */
1972 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1973 value = build_fold_indirect_ref_loc (input_location,
1976 /* If the argument is an array descriptor, use it to determine
1977 information about the actual argument's shape. */
1978 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1979 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1981 /* Get the actual argument's descriptor. */
1982 desc = build_fold_indirect_ref_loc (input_location,
1985 /* Create the replacement variable. */
1986 tmp = gfc_conv_descriptor_data_get (desc);
1987 value = gfc_get_interface_mapping_array (&se->pre, sym,
1990 /* Use DESC to work out the upper bounds, strides and offset. */
1991 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1994 /* Otherwise we have a packed array. */
1995 value = gfc_get_interface_mapping_array (&se->pre, sym,
1996 PACKED_FULL, se->expr);
1998 new_sym->backend_decl = value;
2002 /* Called once all dummy argument mappings have been added to MAPPING,
2003 but before the mapping is used to evaluate expressions. Pre-evaluate
2004 the length of each argument, adding any initialization code to PRE and
2005 any finalization code to POST. */
2008 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2009 stmtblock_t * pre, stmtblock_t * post)
2011 gfc_interface_sym_mapping *sym;
2015 for (sym = mapping->syms; sym; sym = sym->next)
2016 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2017 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2019 expr = sym->new_sym->n.sym->ts.u.cl->length;
2020 gfc_apply_interface_mapping_to_expr (mapping, expr);
2021 gfc_init_se (&se, NULL);
2022 gfc_conv_expr (&se, expr);
2023 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2024 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2025 gfc_add_block_to_block (pre, &se.pre);
2026 gfc_add_block_to_block (post, &se.post);
2028 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2033 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2037 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2038 gfc_constructor_base base)
2041 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2043 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2046 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2047 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2048 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2054 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2058 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2063 for (; ref; ref = ref->next)
2067 for (n = 0; n < ref->u.ar.dimen; n++)
2069 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2070 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2071 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2073 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2080 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2081 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2087 /* Convert intrinsic function calls into result expressions. */
2090 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2098 arg1 = expr->value.function.actual->expr;
2099 if (expr->value.function.actual->next)
2100 arg2 = expr->value.function.actual->next->expr;
2104 sym = arg1->symtree->n.sym;
2106 if (sym->attr.dummy)
2111 switch (expr->value.function.isym->id)
2114 /* TODO figure out why this condition is necessary. */
2115 if (sym->attr.function
2116 && (arg1->ts.u.cl->length == NULL
2117 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2118 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2121 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2125 if (!sym->as || sym->as->rank == 0)
2128 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2130 dup = mpz_get_si (arg2->value.integer);
2135 dup = sym->as->rank;
2139 for (; d < dup; d++)
2143 if (!sym->as->upper[d] || !sym->as->lower[d])
2145 gfc_free_expr (new_expr);
2149 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2150 gfc_get_int_expr (gfc_default_integer_kind,
2152 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2154 new_expr = gfc_multiply (new_expr, tmp);
2160 case GFC_ISYM_LBOUND:
2161 case GFC_ISYM_UBOUND:
2162 /* TODO These implementations of lbound and ubound do not limit if
2163 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2165 if (!sym->as || sym->as->rank == 0)
2168 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2169 d = mpz_get_si (arg2->value.integer) - 1;
2171 /* TODO: If the need arises, this could produce an array of
2175 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2177 if (sym->as->lower[d])
2178 new_expr = gfc_copy_expr (sym->as->lower[d]);
2182 if (sym->as->upper[d])
2183 new_expr = gfc_copy_expr (sym->as->upper[d]);
2191 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2195 gfc_replace_expr (expr, new_expr);
2201 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2202 gfc_interface_mapping * mapping)
2204 gfc_formal_arglist *f;
2205 gfc_actual_arglist *actual;
2207 actual = expr->value.function.actual;
2208 f = map_expr->symtree->n.sym->formal;
2210 for (; f && actual; f = f->next, actual = actual->next)
2215 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2218 if (map_expr->symtree->n.sym->attr.dimension)
2223 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2225 for (d = 0; d < as->rank; d++)
2227 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2228 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2231 expr->value.function.esym->as = as;
2234 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2236 expr->value.function.esym->ts.u.cl->length
2237 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2239 gfc_apply_interface_mapping_to_expr (mapping,
2240 expr->value.function.esym->ts.u.cl->length);
2245 /* EXPR is a copy of an expression that appeared in the interface
2246 associated with MAPPING. Walk it recursively looking for references to
2247 dummy arguments that MAPPING maps to actual arguments. Replace each such
2248 reference with a reference to the associated actual argument. */
2251 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2254 gfc_interface_sym_mapping *sym;
2255 gfc_actual_arglist *actual;
2260 /* Copying an expression does not copy its length, so do that here. */
2261 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2263 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2264 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2267 /* Apply the mapping to any references. */
2268 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2270 /* ...and to the expression's symbol, if it has one. */
2271 /* TODO Find out why the condition on expr->symtree had to be moved into
2272 the loop rather than being outside it, as originally. */
2273 for (sym = mapping->syms; sym; sym = sym->next)
2274 if (expr->symtree && sym->old == expr->symtree->n.sym)
2276 if (sym->new_sym->n.sym->backend_decl)
2277 expr->symtree = sym->new_sym;
2279 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2280 /* Replace base type for polymorphic arguments. */
2281 if (expr->ref && expr->ref->type == REF_COMPONENT
2282 && sym->expr && sym->expr->ts.type == BT_CLASS)
2283 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2286 /* ...and to subexpressions in expr->value. */
2287 switch (expr->expr_type)
2292 case EXPR_SUBSTRING:
2296 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2297 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2301 for (actual = expr->value.function.actual; actual; actual = actual->next)
2302 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2304 if (expr->value.function.esym == NULL
2305 && expr->value.function.isym != NULL
2306 && expr->value.function.actual->expr->symtree
2307 && gfc_map_intrinsic_function (expr, mapping))
2310 for (sym = mapping->syms; sym; sym = sym->next)
2311 if (sym->old == expr->value.function.esym)
2313 expr->value.function.esym = sym->new_sym->n.sym;
2314 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2315 expr->value.function.esym->result = sym->new_sym->n.sym;
2320 case EXPR_STRUCTURE:
2321 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2334 /* Evaluate interface expression EXPR using MAPPING. Store the result
2338 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2339 gfc_se * se, gfc_expr * expr)
2341 expr = gfc_copy_expr (expr);
2342 gfc_apply_interface_mapping_to_expr (mapping, expr);
2343 gfc_conv_expr (se, expr);
2344 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2345 gfc_free_expr (expr);
2349 /* Returns a reference to a temporary array into which a component of
2350 an actual argument derived type array is copied and then returned
2351 after the function call. */
2353 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2354 sym_intent intent, bool formal_ptr)
2372 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2374 gfc_init_se (&lse, NULL);
2375 gfc_init_se (&rse, NULL);
2377 /* Walk the argument expression. */
2378 rss = gfc_walk_expr (expr);
2380 gcc_assert (rss != gfc_ss_terminator);
2382 /* Initialize the scalarizer. */
2383 gfc_init_loopinfo (&loop);
2384 gfc_add_ss_to_loop (&loop, rss);
2386 /* Calculate the bounds of the scalarization. */
2387 gfc_conv_ss_startstride (&loop);
2389 /* Build an ss for the temporary. */
2390 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2391 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2393 base_type = gfc_typenode_for_spec (&expr->ts);
2394 if (GFC_ARRAY_TYPE_P (base_type)
2395 || GFC_DESCRIPTOR_TYPE_P (base_type))
2396 base_type = gfc_get_element_type (base_type);
2398 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2399 ? expr->ts.u.cl->backend_decl
2403 parmse->string_length = loop.temp_ss->string_length;
2405 /* Associate the SS with the loop. */
2406 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2408 /* Setup the scalarizing loops. */
2409 gfc_conv_loop_setup (&loop, &expr->where);
2411 /* Pass the temporary descriptor back to the caller. */
2412 info = &loop.temp_ss->data.info;
2413 parmse->expr = info->descriptor;
2415 /* Setup the gfc_se structures. */
2416 gfc_copy_loopinfo_to_se (&lse, &loop);
2417 gfc_copy_loopinfo_to_se (&rse, &loop);
2420 lse.ss = loop.temp_ss;
2421 gfc_mark_ss_chain_used (rss, 1);
2422 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2424 /* Start the scalarized loop body. */
2425 gfc_start_scalarized_body (&loop, &body);
2427 /* Translate the expression. */
2428 gfc_conv_expr (&rse, expr);
2430 gfc_conv_tmp_array_ref (&lse);
2432 if (intent != INTENT_OUT)
2434 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2435 gfc_add_expr_to_block (&body, tmp);
2436 gcc_assert (rse.ss == gfc_ss_terminator);
2437 gfc_trans_scalarizing_loops (&loop, &body);
2441 /* Make sure that the temporary declaration survives by merging
2442 all the loop declarations into the current context. */
2443 for (n = 0; n < loop.dimen; n++)
2445 gfc_merge_block_scope (&body);
2446 body = loop.code[loop.order[n]];
2448 gfc_merge_block_scope (&body);
2451 /* Add the post block after the second loop, so that any
2452 freeing of allocated memory is done at the right time. */
2453 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2455 /**********Copy the temporary back again.*********/
2457 gfc_init_se (&lse, NULL);
2458 gfc_init_se (&rse, NULL);
2460 /* Walk the argument expression. */
2461 lss = gfc_walk_expr (expr);
2462 rse.ss = loop.temp_ss;
2465 /* Initialize the scalarizer. */
2466 gfc_init_loopinfo (&loop2);
2467 gfc_add_ss_to_loop (&loop2, lss);
2469 /* Calculate the bounds of the scalarization. */
2470 gfc_conv_ss_startstride (&loop2);
2472 /* Setup the scalarizing loops. */
2473 gfc_conv_loop_setup (&loop2, &expr->where);
2475 gfc_copy_loopinfo_to_se (&lse, &loop2);
2476 gfc_copy_loopinfo_to_se (&rse, &loop2);
2478 gfc_mark_ss_chain_used (lss, 1);
2479 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2481 /* Declare the variable to hold the temporary offset and start the
2482 scalarized loop body. */
2483 offset = gfc_create_var (gfc_array_index_type, NULL);
2484 gfc_start_scalarized_body (&loop2, &body);
2486 /* Build the offsets for the temporary from the loop variables. The
2487 temporary array has lbounds of zero and strides of one in all
2488 dimensions, so this is very simple. The offset is only computed
2489 outside the innermost loop, so the overall transfer could be
2490 optimized further. */
2491 info = &rse.ss->data.info;
2492 dimen = info->dimen;
2494 tmp_index = gfc_index_zero_node;
2495 for (n = dimen - 1; n > 0; n--)
2498 tmp = rse.loop->loopvar[n];
2499 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2500 tmp, rse.loop->from[n]);
2501 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2504 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2505 gfc_array_index_type,
2506 rse.loop->to[n-1], rse.loop->from[n-1]);
2507 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2508 gfc_array_index_type,
2509 tmp_str, gfc_index_one_node);
2511 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2512 gfc_array_index_type, tmp, tmp_str);
2515 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2516 gfc_array_index_type,
2517 tmp_index, rse.loop->from[0]);
2518 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2520 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2521 gfc_array_index_type,
2522 rse.loop->loopvar[0], offset);
2524 /* Now use the offset for the reference. */
2525 tmp = build_fold_indirect_ref_loc (input_location,
2527 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2529 if (expr->ts.type == BT_CHARACTER)
2530 rse.string_length = expr->ts.u.cl->backend_decl;
2532 gfc_conv_expr (&lse, expr);
2534 gcc_assert (lse.ss == gfc_ss_terminator);
2536 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2537 gfc_add_expr_to_block (&body, tmp);
2539 /* Generate the copying loops. */
2540 gfc_trans_scalarizing_loops (&loop2, &body);
2542 /* Wrap the whole thing up by adding the second loop to the post-block
2543 and following it by the post-block of the first loop. In this way,
2544 if the temporary needs freeing, it is done after use! */
2545 if (intent != INTENT_IN)
2547 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2548 gfc_add_block_to_block (&parmse->post, &loop2.post);
2551 gfc_add_block_to_block (&parmse->post, &loop.post);
2553 gfc_cleanup_loop (&loop);
2554 gfc_cleanup_loop (&loop2);
2556 /* Pass the string length to the argument expression. */
2557 if (expr->ts.type == BT_CHARACTER)
2558 parmse->string_length = expr->ts.u.cl->backend_decl;
2560 /* Determine the offset for pointer formal arguments and set the
2564 size = gfc_index_one_node;
2565 offset = gfc_index_zero_node;
2566 for (n = 0; n < dimen; n++)
2568 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2570 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2571 gfc_array_index_type, tmp,
2572 gfc_index_one_node);
2573 gfc_conv_descriptor_ubound_set (&parmse->pre,
2577 gfc_conv_descriptor_lbound_set (&parmse->pre,
2580 gfc_index_one_node);
2581 size = gfc_evaluate_now (size, &parmse->pre);
2582 offset = fold_build2_loc (input_location, MINUS_EXPR,
2583 gfc_array_index_type,
2585 offset = gfc_evaluate_now (offset, &parmse->pre);
2586 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2587 gfc_array_index_type,
2588 rse.loop->to[n], rse.loop->from[n]);
2589 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2590 gfc_array_index_type,
2591 tmp, gfc_index_one_node);
2592 size = fold_build2_loc (input_location, MULT_EXPR,
2593 gfc_array_index_type, size, tmp);
2596 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2600 /* We want either the address for the data or the address of the descriptor,
2601 depending on the mode of passing array arguments. */
2603 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2605 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2611 /* Generate the code for argument list functions. */
2614 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2616 /* Pass by value for g77 %VAL(arg), pass the address
2617 indirectly for %LOC, else by reference. Thus %REF
2618 is a "do-nothing" and %LOC is the same as an F95
2620 if (strncmp (name, "%VAL", 4) == 0)
2621 gfc_conv_expr (se, expr);
2622 else if (strncmp (name, "%LOC", 4) == 0)
2624 gfc_conv_expr_reference (se, expr);
2625 se->expr = gfc_build_addr_expr (NULL, se->expr);
2627 else if (strncmp (name, "%REF", 4) == 0)
2628 gfc_conv_expr_reference (se, expr);
2630 gfc_error ("Unknown argument list function at %L", &expr->where);
2634 /* Takes a derived type expression and returns the address of a temporary
2635 class object of the 'declared' type. */
2637 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2638 gfc_typespec class_ts)
2642 gfc_symbol *declared = class_ts.u.derived;
2648 /* The derived type needs to be converted to a temporary
2650 tmp = gfc_typenode_for_spec (&class_ts);
2651 var = gfc_create_var (tmp, "class");
2654 cmp = gfc_find_component (declared, "_vptr", true, true);
2655 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2656 TREE_TYPE (cmp->backend_decl),
2657 var, cmp->backend_decl, NULL_TREE);
2659 /* Remember the vtab corresponds to the derived type
2660 not to the class declared type. */
2661 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2663 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2664 gfc_add_modify (&parmse->pre, ctree,
2665 fold_convert (TREE_TYPE (ctree), tmp));
2667 /* Now set the data field. */
2668 cmp = gfc_find_component (declared, "_data", true, true);
2669 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2670 TREE_TYPE (cmp->backend_decl),
2671 var, cmp->backend_decl, NULL_TREE);
2672 ss = gfc_walk_expr (e);
2673 if (ss == gfc_ss_terminator)
2676 gfc_conv_expr_reference (parmse, e);
2677 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2678 gfc_add_modify (&parmse->pre, ctree, tmp);
2683 gfc_conv_expr (parmse, e);
2684 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2687 /* Pass the address of the class object. */
2688 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2692 /* The following routine generates code for the intrinsic
2693 procedures from the ISO_C_BINDING module:
2695 * C_FUNLOC (function)
2696 * C_F_POINTER (subroutine)
2697 * C_F_PROCPOINTER (subroutine)
2698 * C_ASSOCIATED (function)
2699 One exception which is not handled here is C_F_POINTER with non-scalar
2700 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2703 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2704 gfc_actual_arglist * arg)
2709 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2711 if (arg->expr->rank == 0)
2712 gfc_conv_expr_reference (se, arg->expr);
2716 /* This is really the actual arg because no formal arglist is
2717 created for C_LOC. */
2718 fsym = arg->expr->symtree->n.sym;
2720 /* We should want it to do g77 calling convention. */
2722 && !(fsym->attr.pointer || fsym->attr.allocatable)
2723 && fsym->as->type != AS_ASSUMED_SHAPE;
2724 f = f || !sym->attr.always_explicit;
2726 argss = gfc_walk_expr (arg->expr);
2727 gfc_conv_array_parameter (se, arg->expr, argss, f,
2731 /* TODO -- the following two lines shouldn't be necessary, but if
2732 they're removed, a bug is exposed later in the code path.
2733 This workaround was thus introduced, but will have to be
2734 removed; please see PR 35150 for details about the issue. */
2735 se->expr = convert (pvoid_type_node, se->expr);
2736 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2740 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2742 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2743 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2744 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2745 gfc_conv_expr_reference (se, arg->expr);
2749 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2750 && arg->next->expr->rank == 0)
2751 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2753 /* Convert c_f_pointer if fptr is a scalar
2754 and convert c_f_procpointer. */
2758 gfc_init_se (&cptrse, NULL);
2759 gfc_conv_expr (&cptrse, arg->expr);
2760 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2761 gfc_add_block_to_block (&se->post, &cptrse.post);
2763 gfc_init_se (&fptrse, NULL);
2764 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2765 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2766 fptrse.want_pointer = 1;
2768 gfc_conv_expr (&fptrse, arg->next->expr);
2769 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2770 gfc_add_block_to_block (&se->post, &fptrse.post);
2772 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2773 && arg->next->expr->symtree->n.sym->attr.dummy)
2774 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2777 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2778 TREE_TYPE (fptrse.expr),
2780 fold_convert (TREE_TYPE (fptrse.expr),
2785 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2790 /* Build the addr_expr for the first argument. The argument is
2791 already an *address* so we don't need to set want_pointer in
2793 gfc_init_se (&arg1se, NULL);
2794 gfc_conv_expr (&arg1se, arg->expr);
2795 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2796 gfc_add_block_to_block (&se->post, &arg1se.post);
2798 /* See if we were given two arguments. */
2799 if (arg->next == NULL)
2800 /* Only given one arg so generate a null and do a
2801 not-equal comparison against the first arg. */
2802 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2804 fold_convert (TREE_TYPE (arg1se.expr),
2805 null_pointer_node));
2811 /* Given two arguments so build the arg2se from second arg. */
2812 gfc_init_se (&arg2se, NULL);
2813 gfc_conv_expr (&arg2se, arg->next->expr);
2814 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2815 gfc_add_block_to_block (&se->post, &arg2se.post);
2817 /* Generate test to compare that the two args are equal. */
2818 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2819 arg1se.expr, arg2se.expr);
2820 /* Generate test to ensure that the first arg is not null. */
2821 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2823 arg1se.expr, null_pointer_node);
2825 /* Finally, the generated test must check that both arg1 is not
2826 NULL and that it is equal to the second arg. */
2827 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2829 not_null_expr, eq_expr);
2835 /* Nothing was done. */
2840 /* Generate code for a procedure call. Note can return se->post != NULL.
2841 If se->direct_byref is set then se->expr contains the return parameter.
2842 Return nonzero, if the call has alternate specifiers.
2843 'expr' is only needed for procedure pointer components. */
2846 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2847 gfc_actual_arglist * args, gfc_expr * expr,
2848 VEC(tree,gc) *append_args)
2850 gfc_interface_mapping mapping;
2851 VEC(tree,gc) *arglist;
2852 VEC(tree,gc) *retargs;
2863 VEC(tree,gc) *stringargs;
2865 gfc_formal_arglist *formal;
2866 gfc_actual_arglist *arg;
2867 int has_alternate_specifier = 0;
2868 bool need_interface_mapping;
2875 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2876 gfc_component *comp = NULL;
2886 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2887 && conv_isocbinding_procedure (se, sym, args))
2890 gfc_is_proc_ptr_comp (expr, &comp);
2894 if (!sym->attr.elemental)
2896 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2897 if (se->ss->useflags)
2899 gcc_assert ((!comp && gfc_return_by_reference (sym)
2900 && sym->result->attr.dimension)
2901 || (comp && comp->attr.dimension));
2902 gcc_assert (se->loop != NULL);
2904 /* Access the previously obtained result. */
2905 gfc_conv_tmp_array_ref (se);
2909 info = &se->ss->data.info;
2914 gfc_init_block (&post);
2915 gfc_init_interface_mapping (&mapping);
2918 formal = sym->formal;
2919 need_interface_mapping = sym->attr.dimension ||
2920 (sym->ts.type == BT_CHARACTER
2921 && sym->ts.u.cl->length
2922 && sym->ts.u.cl->length->expr_type
2927 formal = comp->formal;
2928 need_interface_mapping = comp->attr.dimension ||
2929 (comp->ts.type == BT_CHARACTER
2930 && comp->ts.u.cl->length
2931 && comp->ts.u.cl->length->expr_type
2935 /* Evaluate the arguments. */
2936 for (arg = args; arg != NULL;
2937 arg = arg->next, formal = formal ? formal->next : NULL)
2940 fsym = formal ? formal->sym : NULL;
2941 parm_kind = MISSING;
2945 if (se->ignore_optional)
2947 /* Some intrinsics have already been resolved to the correct
2951 else if (arg->label)
2953 has_alternate_specifier = 1;
2958 /* Pass a NULL pointer for an absent arg. */
2959 gfc_init_se (&parmse, NULL);
2960 parmse.expr = null_pointer_node;
2961 if (arg->missing_arg_type == BT_CHARACTER)
2962 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2965 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2967 /* Pass a NULL pointer to denote an absent arg. */
2968 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2969 gfc_init_se (&parmse, NULL);
2970 parmse.expr = null_pointer_node;
2971 if (arg->missing_arg_type == BT_CHARACTER)
2972 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2974 else if (fsym && fsym->ts.type == BT_CLASS
2975 && e->ts.type == BT_DERIVED)
2977 /* The derived type needs to be converted to a temporary
2979 gfc_init_se (&parmse, se);
2980 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2982 else if (se->ss && se->ss->useflags)
2984 /* An elemental function inside a scalarized loop. */
2985 gfc_init_se (&parmse, se);
2986 gfc_conv_expr_reference (&parmse, e);
2987 parm_kind = ELEMENTAL;
2991 /* A scalar or transformational function. */
2992 gfc_init_se (&parmse, NULL);
2993 argss = gfc_walk_expr (e);
2995 if (argss == gfc_ss_terminator)
2997 if (e->expr_type == EXPR_VARIABLE
2998 && e->symtree->n.sym->attr.cray_pointee
2999 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3001 /* The Cray pointer needs to be converted to a pointer to
3002 a type given by the expression. */
3003 gfc_conv_expr (&parmse, e);
3004 type = build_pointer_type (TREE_TYPE (parmse.expr));
3005 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3006 parmse.expr = convert (type, tmp);
3008 else if (fsym && fsym->attr.value)
3010 if (fsym->ts.type == BT_CHARACTER
3011 && fsym->ts.is_c_interop
3012 && fsym->ns->proc_name != NULL
3013 && fsym->ns->proc_name->attr.is_bind_c)
3016 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3017 if (parmse.expr == NULL)
3018 gfc_conv_expr (&parmse, e);
3021 gfc_conv_expr (&parmse, e);
3023 else if (arg->name && arg->name[0] == '%')
3024 /* Argument list functions %VAL, %LOC and %REF are signalled
3025 through arg->name. */
3026 conv_arglist_function (&parmse, arg->expr, arg->name);
3027 else if ((e->expr_type == EXPR_FUNCTION)
3028 && ((e->value.function.esym
3029 && e->value.function.esym->result->attr.pointer)
3030 || (!e->value.function.esym
3031 && e->symtree->n.sym->attr.pointer))
3032 && fsym && fsym->attr.target)
3034 gfc_conv_expr (&parmse, e);
3035 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3037 else if (e->expr_type == EXPR_FUNCTION
3038 && e->symtree->n.sym->result
3039 && e->symtree->n.sym->result != e->symtree->n.sym
3040 && e->symtree->n.sym->result->attr.proc_pointer)
3042 /* Functions returning procedure pointers. */
3043 gfc_conv_expr (&parmse, e);
3044 if (fsym && fsym->attr.proc_pointer)
3045 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3049 gfc_conv_expr_reference (&parmse, e);
3051 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3052 allocated on entry, it must be deallocated. */
3053 if (fsym && fsym->attr.allocatable
3054 && fsym->attr.intent == INTENT_OUT)
3058 gfc_init_block (&block);
3059 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3061 gfc_add_expr_to_block (&block, tmp);
3062 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3063 void_type_node, parmse.expr,
3065 gfc_add_expr_to_block (&block, tmp);
3067 if (fsym->attr.optional
3068 && e->expr_type == EXPR_VARIABLE
3069 && e->symtree->n.sym->attr.optional)
3071 tmp = fold_build3_loc (input_location, COND_EXPR,
3073 gfc_conv_expr_present (e->symtree->n.sym),
3074 gfc_finish_block (&block),
3075 build_empty_stmt (input_location));
3078 tmp = gfc_finish_block (&block);
3080 gfc_add_expr_to_block (&se->pre, tmp);
3083 if (fsym && e->expr_type != EXPR_NULL
3084 && ((fsym->attr.pointer
3085 && fsym->attr.flavor != FL_PROCEDURE)
3086 || (fsym->attr.proc_pointer
3087 && !(e->expr_type == EXPR_VARIABLE
3088 && e->symtree->n.sym->attr.dummy))
3089 || (fsym->attr.proc_pointer
3090 && e->expr_type == EXPR_VARIABLE
3091 && gfc_is_proc_ptr_comp (e, NULL))
3092 || fsym->attr.allocatable))
3094 /* Scalar pointer dummy args require an extra level of
3095 indirection. The null pointer already contains
3096 this level of indirection. */
3097 parm_kind = SCALAR_POINTER;
3098 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3104 /* If the procedure requires an explicit interface, the actual
3105 argument is passed according to the corresponding formal
3106 argument. If the corresponding formal argument is a POINTER,
3107 ALLOCATABLE or assumed shape, we do not use g77's calling
3108 convention, and pass the address of the array descriptor
3109 instead. Otherwise we use g77's calling convention. */
3112 && !(fsym->attr.pointer || fsym->attr.allocatable)
3113 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3115 f = f || !comp->attr.always_explicit;
3117 f = f || !sym->attr.always_explicit;
3119 /* If the argument is a function call that may not create
3120 a temporary for the result, we have to check that we
3121 can do it, i.e. that there is no alias between this
3122 argument and another one. */
3123 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3129 intent = fsym->attr.intent;
3131 intent = INTENT_UNKNOWN;
3133 if (gfc_check_fncall_dependency (e, intent, sym, args,
3135 parmse.force_tmp = 1;
3137 iarg = e->value.function.actual->expr;
3139 /* Temporary needed if aliasing due to host association. */
3140 if (sym->attr.contained
3142 && !sym->attr.implicit_pure
3143 && !sym->attr.use_assoc
3144 && iarg->expr_type == EXPR_VARIABLE
3145 && sym->ns == iarg->symtree->n.sym->ns)
3146 parmse.force_tmp = 1;
3148 /* Ditto within module. */
3149 if (sym->attr.use_assoc
3151 && !sym->attr.implicit_pure
3152 && iarg->expr_type == EXPR_VARIABLE
3153 && sym->module == iarg->symtree->n.sym->module)
3154 parmse.force_tmp = 1;
3157 if (e->expr_type == EXPR_VARIABLE
3158 && is_subref_array (e))
3159 /* The actual argument is a component reference to an
3160 array of derived types. In this case, the argument
3161 is converted to a temporary, which is passed and then
3162 written back after the procedure call. */
3163 gfc_conv_subref_array_arg (&parmse, e, f,
3164 fsym ? fsym->attr.intent : INTENT_INOUT,
3165 fsym && fsym->attr.pointer);
3167 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3170 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3171 allocated on entry, it must be deallocated. */
3172 if (fsym && fsym->attr.allocatable
3173 && fsym->attr.intent == INTENT_OUT)
3175 tmp = build_fold_indirect_ref_loc (input_location,
3177 tmp = gfc_trans_dealloc_allocated (tmp);
3178 if (fsym->attr.optional
3179 && e->expr_type == EXPR_VARIABLE
3180 && e->symtree->n.sym->attr.optional)
3181 tmp = fold_build3_loc (input_location, COND_EXPR,
3183 gfc_conv_expr_present (e->symtree->n.sym),
3184 tmp, build_empty_stmt (input_location));
3185 gfc_add_expr_to_block (&se->pre, tmp);
3190 /* The case with fsym->attr.optional is that of a user subroutine
3191 with an interface indicating an optional argument. When we call
3192 an intrinsic subroutine, however, fsym is NULL, but we might still
3193 have an optional argument, so we proceed to the substitution
3195 if (e && (fsym == NULL || fsym->attr.optional))
3197 /* If an optional argument is itself an optional dummy argument,
3198 check its presence and substitute a null if absent. This is
3199 only needed when passing an array to an elemental procedure
3200 as then array elements are accessed - or no NULL pointer is
3201 allowed and a "1" or "0" should be passed if not present.
3202 When passing a non-array-descriptor full array to a
3203 non-array-descriptor dummy, no check is needed. For
3204 array-descriptor actual to array-descriptor dummy, see
3205 PR 41911 for why a check has to be inserted.
3206 fsym == NULL is checked as intrinsics required the descriptor
3207 but do not always set fsym. */
3208 if (e->expr_type == EXPR_VARIABLE
3209 && e->symtree->n.sym->attr.optional
3210 && ((e->rank > 0 && sym->attr.elemental)
3211 || e->representation.length || e->ts.type == BT_CHARACTER
3215 && (fsym->as->type == AS_ASSUMED_SHAPE
3216 || fsym->as->type == AS_DEFERRED))))))
3217 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3218 e->representation.length);
3223 /* Obtain the character length of an assumed character length
3224 length procedure from the typespec. */
3225 if (fsym->ts.type == BT_CHARACTER
3226 && parmse.string_length == NULL_TREE
3227 && e->ts.type == BT_PROCEDURE
3228 && e->symtree->n.sym->ts.type == BT_CHARACTER
3229 && e->symtree->n.sym->ts.u.cl->length != NULL
3230 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3232 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3233 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3237 if (fsym && need_interface_mapping && e)
3238 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3240 gfc_add_block_to_block (&se->pre, &parmse.pre);
3241 gfc_add_block_to_block (&post, &parmse.post);
3243 /* Allocated allocatable components of derived types must be
3244 deallocated for non-variable scalars. Non-variable arrays are
3245 dealt with in trans-array.c(gfc_conv_array_parameter). */
3246 if (e && e->ts.type == BT_DERIVED
3247 && e->ts.u.derived->attr.alloc_comp
3248 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3249 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3252 tmp = build_fold_indirect_ref_loc (input_location,
3254 parm_rank = e->rank;
3262 case (SCALAR_POINTER):
3263 tmp = build_fold_indirect_ref_loc (input_location,
3268 if (e->expr_type == EXPR_OP
3269 && e->value.op.op == INTRINSIC_PARENTHESES
3270 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3273 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3274 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3275 gfc_add_expr_to_block (&se->post, local_tmp);
3278 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3280 gfc_add_expr_to_block (&se->post, tmp);
3283 /* Add argument checking of passing an unallocated/NULL actual to
3284 a nonallocatable/nonpointer dummy. */
3286 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3288 symbol_attribute attr;
3292 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3293 attr = gfc_expr_attr (e);
3295 goto end_pointer_check;
3297 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3298 allocatable to an optional dummy, cf. 12.5.2.12. */
3299 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3300 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3301 goto end_pointer_check;
3305 /* If the actual argument is an optional pointer/allocatable and
3306 the formal argument takes an nonpointer optional value,
3307 it is invalid to pass a non-present argument on, even
3308 though there is no technical reason for this in gfortran.
3309 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3310 tree present, null_ptr, type;
3312 if (attr.allocatable
3313 && (fsym == NULL || !fsym->attr.allocatable))
3314 asprintf (&msg, "Allocatable actual argument '%s' is not "
3315 "allocated or not present", e->symtree->n.sym->name);
3316 else if (attr.pointer
3317 && (fsym == NULL || !fsym->attr.pointer))
3318 asprintf (&msg, "Pointer actual argument '%s' is not "
3319 "associated or not present",
3320 e->symtree->n.sym->name);
3321 else if (attr.proc_pointer
3322 && (fsym == NULL || !fsym->attr.proc_pointer))
3323 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3324 "associated or not present",
3325 e->symtree->n.sym->name);
3327 goto end_pointer_check;
3329 present = gfc_conv_expr_present (e->symtree->n.sym);
3330 type = TREE_TYPE (present);
3331 present = fold_build2_loc (input_location, EQ_EXPR,
3332 boolean_type_node, present,
3334 null_pointer_node));
3335 type = TREE_TYPE (parmse.expr);
3336 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3337 boolean_type_node, parmse.expr,
3339 null_pointer_node));
3340 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3341 boolean_type_node, present, null_ptr);
3345 if (attr.allocatable
3346 && (fsym == NULL || !fsym->attr.allocatable))
3347 asprintf (&msg, "Allocatable actual argument '%s' is not "
3348 "allocated", e->symtree->n.sym->name);
3349 else if (attr.pointer
3350 && (fsym == NULL || !fsym->attr.pointer))
3351 asprintf (&msg, "Pointer actual argument '%s' is not "
3352 "associated", e->symtree->n.sym->name);
3353 else if (attr.proc_pointer
3354 && (fsym == NULL || !fsym->attr.proc_pointer))
3355 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3356 "associated", e->symtree->n.sym->name);
3358 goto end_pointer_check;
3361 cond = fold_build2_loc (input_location, EQ_EXPR,
3362 boolean_type_node, parmse.expr,
3363 fold_convert (TREE_TYPE (parmse.expr),
3364 null_pointer_node));
3367 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3373 /* Deferred length dummies pass the character length by reference
3374 so that the value can be returned. */
3375 if (parmse.string_length && fsym && fsym->ts.deferred)
3377 tmp = parmse.string_length;
3378 if (TREE_CODE (tmp) != VAR_DECL)
3379 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3380 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3383 /* Character strings are passed as two parameters, a length and a
3384 pointer - except for Bind(c) which only passes the pointer. */
3385 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3386 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3388 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3389 pass the token and the offset as additional arguments. */
3390 if (fsym && fsym->attr.codimension
3391 && gfc_option.coarray == GFC_FCOARRAY_LIB
3392 && !fsym->attr.allocatable
3395 /* Token and offset. */
3396 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
3397 VEC_safe_push (tree, gc, stringargs,
3398 build_int_cst (gfc_array_index_type, 0));
3399 gcc_assert (fsym->attr.optional);
3401 else if (fsym && fsym->attr.codimension
3402 && !fsym->attr.allocatable
3403 && gfc_option.coarray == GFC_FCOARRAY_LIB)
3405 tree caf_decl, caf_type;
3408 caf_decl = get_tree_for_caf_expr (e);
3409 caf_type = TREE_TYPE (caf_decl);
3411 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3412 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3413 tmp = gfc_conv_descriptor_token (caf_decl);
3414 else if (DECL_LANG_SPECIFIC (caf_decl)
3415 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
3416 tmp = GFC_DECL_TOKEN (caf_decl);
3419 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
3420 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
3421 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
3424 VEC_safe_push (tree, gc, stringargs, tmp);
3426 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3427 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3428 offset = build_int_cst (gfc_array_index_type, 0);
3429 else if (DECL_LANG_SPECIFIC (caf_decl)
3430 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
3431 offset = GFC_DECL_CAF_OFFSET (caf_decl);
3432 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3433 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
3435 offset = build_int_cst (gfc_array_index_type, 0);
3437 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
3438 tmp = gfc_conv_descriptor_data_get (caf_decl);
3441 gcc_assert (POINTER_TYPE_P (caf_type));
3445 if (fsym->as->type == AS_ASSUMED_SHAPE)
3447 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3448 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3449 (TREE_TYPE (parmse.expr))));
3450 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
3451 tmp2 = gfc_conv_descriptor_data_get (tmp2);
3453 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3454 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
3457 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3461 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3462 gfc_array_index_type,
3463 fold_convert (gfc_array_index_type, tmp2),
3464 fold_convert (gfc_array_index_type, tmp));
3465 offset = fold_build2_loc (input_location, PLUS_EXPR,
3466 gfc_array_index_type, offset, tmp);
3468 VEC_safe_push (tree, gc, stringargs, offset);
3471 VEC_safe_push (tree, gc, arglist, parmse.expr);
3473 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3480 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3481 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3482 else if (ts.type == BT_CHARACTER)
3484 if (ts.u.cl->length == NULL)
3486 /* Assumed character length results are not allowed by 5.1.1.5 of the
3487 standard and are trapped in resolve.c; except in the case of SPREAD
3488 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3489 we take the character length of the first argument for the result.
3490 For dummies, we have to look through the formal argument list for
3491 this function and use the character length found there.*/
3492 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3493 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3494 else if (!sym->attr.dummy)
3495 cl.backend_decl = VEC_index (tree, stringargs, 0);
3498 formal = sym->ns->proc_name->formal;
3499 for (; formal; formal = formal->next)
3500 if (strcmp (formal->sym->name, sym->name) == 0)
3501 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3508 /* Calculate the length of the returned string. */
3509 gfc_init_se (&parmse, NULL);
3510 if (need_interface_mapping)
3511 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3513 gfc_conv_expr (&parmse, ts.u.cl->length);
3514 gfc_add_block_to_block (&se->pre, &parmse.pre);
3515 gfc_add_block_to_block (&se->post, &parmse.post);
3517 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3518 tmp = fold_build2_loc (input_location, MAX_EXPR,
3519 gfc_charlen_type_node, tmp,
3520 build_int_cst (gfc_charlen_type_node, 0));
3521 cl.backend_decl = tmp;
3524 /* Set up a charlen structure for it. */
3529 len = cl.backend_decl;
3532 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3533 || (!comp && gfc_return_by_reference (sym));
3536 if (se->direct_byref)
3538 /* Sometimes, too much indirection can be applied; e.g. for
3539 function_result = array_valued_recursive_function. */
3540 if (TREE_TYPE (TREE_TYPE (se->expr))
3541 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3542 && GFC_DESCRIPTOR_TYPE_P
3543 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3544 se->expr = build_fold_indirect_ref_loc (input_location,
3547 /* If the lhs of an assignment x = f(..) is allocatable and
3548 f2003 is allowed, we must do the automatic reallocation.
3549 TODO - deal with intrinsics, without using a temporary. */
3550 if (gfc_option.flag_realloc_lhs
3551 && se->ss && se->ss->loop_chain
3552 && se->ss->loop_chain->is_alloc_lhs
3553 && !expr->value.function.isym
3554 && sym->result->as != NULL)
3556 /* Evaluate the bounds of the result, if known. */
3557 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3560 /* Perform the automatic reallocation. */
3561 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3563 gfc_add_expr_to_block (&se->pre, tmp);
3565 /* Pass the temporary as the first argument. */
3566 result = info->descriptor;
3569 result = build_fold_indirect_ref_loc (input_location,
3571 VEC_safe_push (tree, gc, retargs, se->expr);
3573 else if (comp && comp->attr.dimension)
3575 gcc_assert (se->loop && info);
3577 /* Set the type of the array. */
3578 tmp = gfc_typenode_for_spec (&comp->ts);
3579 info->dimen = se->loop->dimen;
3581 /* Evaluate the bounds of the result, if known. */
3582 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3584 /* If the lhs of an assignment x = f(..) is allocatable and
3585 f2003 is allowed, we must not generate the function call
3586 here but should just send back the results of the mapping.
3587 This is signalled by the function ss being flagged. */
3588 if (gfc_option.flag_realloc_lhs
3589 && se->ss && se->ss->is_alloc_lhs)
3591 gfc_free_interface_mapping (&mapping);
3592 return has_alternate_specifier;
3595 /* Create a temporary to store the result. In case the function
3596 returns a pointer, the temporary will be a shallow copy and
3597 mustn't be deallocated. */
3598 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3599 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3600 NULL_TREE, false, !comp->attr.pointer,
3601 callee_alloc, &se->ss->expr->where);
3603 /* Pass the temporary as the first argument. */
3604 result = info->descriptor;
3605 tmp = gfc_build_addr_expr (NULL_TREE, result);
3606 VEC_safe_push (tree, gc, retargs, tmp);
3608 else if (!comp && sym->result->attr.dimension)
3610 gcc_assert (se->loop && info);
3612 /* Set the type of the array. */
3613 tmp = gfc_typenode_for_spec (&ts);
3614 info->dimen = se->loop->dimen;
3616 /* Evaluate the bounds of the result, if known. */
3617 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3619 /* If the lhs of an assignment x = f(..) is allocatable and
3620 f2003 is allowed, we must not generate the function call
3621 here but should just send back the results of the mapping.
3622 This is signalled by the function ss being flagged. */
3623 if (gfc_option.flag_realloc_lhs
3624 && se->ss && se->ss->is_alloc_lhs)
3626 gfc_free_interface_mapping (&mapping);
3627 return has_alternate_specifier;
3630 /* Create a temporary to store the result. In case the function
3631 returns a pointer, the temporary will be a shallow copy and
3632 mustn't be deallocated. */
3633 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3634 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3635 NULL_TREE, false, !sym->attr.pointer,
3636 callee_alloc, &se->ss->expr->where);
3638 /* Pass the temporary as the first argument. */
3639 result = info->descriptor;
3640 tmp = gfc_build_addr_expr (NULL_TREE, result);
3641 VEC_safe_push (tree, gc, retargs, tmp);
3643 else if (ts.type == BT_CHARACTER)
3645 /* Pass the string length. */
3646 type = gfc_get_character_type (ts.kind, ts.u.cl);
3647 type = build_pointer_type (type);
3649 /* Return an address to a char[0:len-1]* temporary for
3650 character pointers. */
3651 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3652 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3654 var = gfc_create_var (type, "pstr");
3656 if ((!comp && sym->attr.allocatable)
3657 || (comp && comp->attr.allocatable))
3658 gfc_add_modify (&se->pre, var,
3659 fold_convert (TREE_TYPE (var),
3660 null_pointer_node));
3662 /* Provide an address expression for the function arguments. */
3663 var = gfc_build_addr_expr (NULL_TREE, var);
3666 var = gfc_conv_string_tmp (se, type, len);
3668 VEC_safe_push (tree, gc, retargs, var);
3672 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3674 type = gfc_get_complex_type (ts.kind);
3675 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3676 VEC_safe_push (tree, gc, retargs, var);
3679 if (ts.type == BT_CHARACTER && ts.deferred
3680 && (sym->attr.allocatable || sym->attr.pointer))
3683 if (TREE_CODE (tmp) != VAR_DECL)
3684 tmp = gfc_evaluate_now (len, &se->pre);
3685 len = gfc_build_addr_expr (NULL_TREE, tmp);
3688 /* Add the string length to the argument list. */
3689 if (ts.type == BT_CHARACTER)
3690 VEC_safe_push (tree, gc, retargs, len);
3692 gfc_free_interface_mapping (&mapping);
3694 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3695 arglen = (VEC_length (tree, arglist)
3696 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3697 VEC_reserve_exact (tree, gc, retargs, arglen);
3699 /* Add the return arguments. */
3700 VEC_splice (tree, retargs, arglist);
3702 /* Add the hidden string length parameters to the arguments. */
3703 VEC_splice (tree, retargs, stringargs);
3705 /* We may want to append extra arguments here. This is used e.g. for
3706 calls to libgfortran_matmul_??, which need extra information. */
3707 if (!VEC_empty (tree, append_args))
3708 VEC_splice (tree, retargs, append_args);
3711 /* Generate the actual call. */
3712 conv_function_val (se, sym, expr);
3714 /* If there are alternate return labels, function type should be
3715 integer. Can't modify the type in place though, since it can be shared
3716 with other functions. For dummy arguments, the typing is done to
3717 this result, even if it has to be repeated for each call. */
3718 if (has_alternate_specifier
3719 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3721 if (!sym->attr.dummy)
3723 TREE_TYPE (sym->backend_decl)
3724 = build_function_type (integer_type_node,
3725 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3726 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3729 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3732 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3733 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3735 /* If we have a pointer function, but we don't want a pointer, e.g.
3738 where f is pointer valued, we have to dereference the result. */
3739 if (!se->want_pointer && !byref
3740 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3741 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3742 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3744 /* f2c calling conventions require a scalar default real function to
3745 return a double precision result. Convert this back to default
3746 real. We only care about the cases that can happen in Fortran 77.
3748 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3749 && sym->ts.kind == gfc_default_real_kind
3750 && !sym->attr.always_explicit)
3751 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3753 /* A pure function may still have side-effects - it may modify its
3755 TREE_SIDE_EFFECTS (se->expr) = 1;
3757 if (!sym->attr.pure)
3758 TREE_SIDE_EFFECTS (se->expr) = 1;
3763 /* Add the function call to the pre chain. There is no expression. */
3764 gfc_add_expr_to_block (&se->pre, se->expr);
3765 se->expr = NULL_TREE;
3767 if (!se->direct_byref)
3769 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3771 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3773 /* Check the data pointer hasn't been modified. This would
3774 happen in a function returning a pointer. */
3775 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3776 tmp = fold_build2_loc (input_location, NE_EXPR,
3779 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3782 se->expr = info->descriptor;
3783 /* Bundle in the string length. */
3784 se->string_length = len;
3786 else if (ts.type == BT_CHARACTER)
3788 /* Dereference for character pointer results. */
3789 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3790 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3791 se->expr = build_fold_indirect_ref_loc (input_location, var);
3796 se->string_length = len;
3797 else if (sym->attr.allocatable || sym->attr.pointer)
3798 se->string_length = cl.backend_decl;
3802 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3803 se->expr = build_fold_indirect_ref_loc (input_location, var);
3808 /* Follow the function call with the argument post block. */
3811 gfc_add_block_to_block (&se->pre, &post);
3813 /* Transformational functions of derived types with allocatable
3814 components must have the result allocatable components copied. */
3815 arg = expr->value.function.actual;
3816 if (result && arg && expr->rank
3817 && expr->value.function.isym
3818 && expr->value.function.isym->transformational
3819 && arg->expr->ts.type == BT_DERIVED
3820 && arg->expr->ts.u.derived->attr.alloc_comp)
3823 /* Copy the allocatable components. We have to use a
3824 temporary here to prevent source allocatable components
3825 from being corrupted. */
3826 tmp2 = gfc_evaluate_now (result, &se->pre);
3827 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3828 result, tmp2, expr->rank);
3829 gfc_add_expr_to_block (&se->pre, tmp);
3830 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3832 gfc_add_expr_to_block (&se->pre, tmp);
3834 /* Finally free the temporary's data field. */
3835 tmp = gfc_conv_descriptor_data_get (tmp2);
3836 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3837 gfc_add_expr_to_block (&se->pre, tmp);
3841 gfc_add_block_to_block (&se->post, &post);
3843 return has_alternate_specifier;
3847 /* Fill a character string with spaces. */
3850 fill_with_spaces (tree start, tree type, tree size)
3852 stmtblock_t block, loop;
3853 tree i, el, exit_label, cond, tmp;
3855 /* For a simple char type, we can call memset(). */
3856 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3857 return build_call_expr_loc (input_location,
3858 built_in_decls[BUILT_IN_MEMSET], 3, start,
3859 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3860 lang_hooks.to_target_charset (' ')),
3863 /* Otherwise, we use a loop:
3864 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3868 /* Initialize variables. */
3869 gfc_init_block (&block);
3870 i = gfc_create_var (sizetype, "i");
3871 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3872 el = gfc_create_var (build_pointer_type (type), "el");
3873 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3874 exit_label = gfc_build_label_decl (NULL_TREE);
3875 TREE_USED (exit_label) = 1;
3879 gfc_init_block (&loop);
3881 /* Exit condition. */
3882 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3883 build_zero_cst (sizetype));
3884 tmp = build1_v (GOTO_EXPR, exit_label);
3885 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3886 build_empty_stmt (input_location));
3887 gfc_add_expr_to_block (&loop, tmp);
3890 gfc_add_modify (&loop,
3891 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3892 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3894 /* Increment loop variables. */
3895 gfc_add_modify (&loop, i,
3896 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3897 TYPE_SIZE_UNIT (type)));
3898 gfc_add_modify (&loop, el,
3899 fold_build_pointer_plus_loc (input_location,
3900 el, TYPE_SIZE_UNIT (type)));
3902 /* Making the loop... actually loop! */
3903 tmp = gfc_finish_block (&loop);
3904 tmp = build1_v (LOOP_EXPR, tmp);
3905 gfc_add_expr_to_block (&block, tmp);
3907 /* The exit label. */
3908 tmp = build1_v (LABEL_EXPR, exit_label);
3909 gfc_add_expr_to_block (&block, tmp);
3912 return gfc_finish_block (&block);
3916 /* Generate code to copy a string. */
3919 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3920 int dkind, tree slength, tree src, int skind)
3922 tree tmp, dlen, slen;
3931 stmtblock_t tempblock;
3933 gcc_assert (dkind == skind);
3935 if (slength != NULL_TREE)
3937 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3938 ssc = gfc_string_to_single_character (slen, src, skind);
3942 slen = build_int_cst (size_type_node, 1);
3946 if (dlength != NULL_TREE)
3948 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3949 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3953 dlen = build_int_cst (size_type_node, 1);
3957 /* Assign directly if the types are compatible. */
3958 if (dsc != NULL_TREE && ssc != NULL_TREE
3959 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3961 gfc_add_modify (block, dsc, ssc);
3965 /* Do nothing if the destination length is zero. */
3966 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3967 build_int_cst (size_type_node, 0));
3969 /* The following code was previously in _gfortran_copy_string:
3971 // The two strings may overlap so we use memmove.
3973 copy_string (GFC_INTEGER_4 destlen, char * dest,
3974 GFC_INTEGER_4 srclen, const char * src)
3976 if (srclen >= destlen)
3978 // This will truncate if too long.
3979 memmove (dest, src, destlen);
3983 memmove (dest, src, srclen);
3985 memset (&dest[srclen], ' ', destlen - srclen);
3989 We're now doing it here for better optimization, but the logic
3992 /* For non-default character kinds, we have to multiply the string
3993 length by the base type size. */
3994 chartype = gfc_get_char_type (dkind);
3995 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3996 fold_convert (size_type_node, slen),
3997 fold_convert (size_type_node,
3998 TYPE_SIZE_UNIT (chartype)));
3999 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4000 fold_convert (size_type_node, dlen),
4001 fold_convert (size_type_node,
4002 TYPE_SIZE_UNIT (chartype)));
4004 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4005 dest = fold_convert (pvoid_type_node, dest);
4007 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4009 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4010 src = fold_convert (pvoid_type_node, src);
4012 src = gfc_build_addr_expr (pvoid_type_node, src);
4014 /* Truncate string if source is too long. */
4015 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4017 tmp2 = build_call_expr_loc (input_location,
4018 built_in_decls[BUILT_IN_MEMMOVE],
4019 3, dest, src, dlen);
4021 /* Else copy and pad with spaces. */
4022 tmp3 = build_call_expr_loc (input_location,
4023 built_in_decls[BUILT_IN_MEMMOVE],
4024 3, dest, src, slen);
4026 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4027 tmp4 = fill_with_spaces (tmp4, chartype,
4028 fold_build2_loc (input_location, MINUS_EXPR,
4029 TREE_TYPE(dlen), dlen, slen));
4031 gfc_init_block (&tempblock);
4032 gfc_add_expr_to_block (&tempblock, tmp3);
4033 gfc_add_expr_to_block (&tempblock, tmp4);
4034 tmp3 = gfc_finish_block (&tempblock);
4036 /* The whole copy_string function is there. */
4037 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4039 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4040 build_empty_stmt (input_location));
4041 gfc_add_expr_to_block (block, tmp);
4045 /* Translate a statement function.
4046 The value of a statement function reference is obtained by evaluating the
4047 expression using the values of the actual arguments for the values of the
4048 corresponding dummy arguments. */
4051 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4055 gfc_formal_arglist *fargs;
4056 gfc_actual_arglist *args;
4059 gfc_saved_var *saved_vars;
4065 sym = expr->symtree->n.sym;
4066 args = expr->value.function.actual;
4067 gfc_init_se (&lse, NULL);
4068 gfc_init_se (&rse, NULL);
4071 for (fargs = sym->formal; fargs; fargs = fargs->next)
4073 saved_vars = XCNEWVEC (gfc_saved_var, n);
4074 temp_vars = XCNEWVEC (tree, n);
4076 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4078 /* Each dummy shall be specified, explicitly or implicitly, to be
4080 gcc_assert (fargs->sym->attr.dimension == 0);
4083 if (fsym->ts.type == BT_CHARACTER)
4085 /* Copy string arguments. */
4088 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4089 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4091 /* Create a temporary to hold the value. */
4092 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4093 fsym->ts.u.cl->backend_decl
4094 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4096 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4097 temp_vars[n] = gfc_create_var (type, fsym->name);
4099 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4101 gfc_conv_expr (&rse, args->expr);
4102 gfc_conv_string_parameter (&rse);
4103 gfc_add_block_to_block (&se->pre, &lse.pre);
4104 gfc_add_block_to_block (&se->pre, &rse.pre);
4106 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4107 rse.string_length, rse.expr, fsym->ts.kind);
4108 gfc_add_block_to_block (&se->pre, &lse.post);
4109 gfc_add_block_to_block (&se->pre, &rse.post);
4113 /* For everything else, just evaluate the expression. */
4115 /* Create a temporary to hold the value. */
4116 type = gfc_typenode_for_spec (&fsym->ts);
4117 temp_vars[n] = gfc_create_var (type, fsym->name);
4119 gfc_conv_expr (&lse, args->expr);
4121 gfc_add_block_to_block (&se->pre, &lse.pre);
4122 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4123 gfc_add_block_to_block (&se->pre, &lse.post);
4129 /* Use the temporary variables in place of the real ones. */
4130 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4131 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4133 gfc_conv_expr (se, sym->value);
4135 if (sym->ts.type == BT_CHARACTER)
4137 gfc_conv_const_charlen (sym->ts.u.cl);
4139 /* Force the expression to the correct length. */
4140 if (!INTEGER_CST_P (se->string_length)
4141 || tree_int_cst_lt (se->string_length,
4142 sym->ts.u.cl->backend_decl))
4144 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4145 tmp = gfc_create_var (type, sym->name);
4146 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4147 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4148 sym->ts.kind, se->string_length, se->expr,
4152 se->string_length = sym->ts.u.cl->backend_decl;
4155 /* Restore the original variables. */
4156 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4157 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4162 /* Translate a function expression. */
4165 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4169 if (expr->value.function.isym)
4171 gfc_conv_intrinsic_function (se, expr);
4175 /* We distinguish statement functions from general functions to improve
4176 runtime performance. */
4177 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4179 gfc_conv_statement_function (se, expr);
4183 /* expr.value.function.esym is the resolved (specific) function symbol for
4184 most functions. However this isn't set for dummy procedures. */
4185 sym = expr->value.function.esym;
4187 sym = expr->symtree->n.sym;
4189 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4193 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4196 is_zero_initializer_p (gfc_expr * expr)
4198 if (expr->expr_type != EXPR_CONSTANT)
4201 /* We ignore constants with prescribed memory representations for now. */
4202 if (expr->representation.string)
4205 switch (expr->ts.type)
4208 return mpz_cmp_si (expr->value.integer, 0) == 0;
4211 return mpfr_zero_p (expr->value.real)
4212 && MPFR_SIGN (expr->value.real) >= 0;
4215 return expr->value.logical == 0;
4218 return mpfr_zero_p (mpc_realref (expr->value.complex))
4219 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4220 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4221 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4231 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4233 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4234 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4236 gfc_conv_tmp_array_ref (se);
4240 /* Build a static initializer. EXPR is the expression for the initial value.
4241 The other parameters describe the variable of the component being
4242 initialized. EXPR may be null. */
4245 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4246 bool array, bool pointer, bool procptr)
4250 if (!(expr || pointer || procptr))
4253 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4254 (these are the only two iso_c_binding derived types that can be
4255 used as initialization expressions). If so, we need to modify
4256 the 'expr' to be that for a (void *). */
4257 if (expr != NULL && expr->ts.type == BT_DERIVED
4258 && expr->ts.is_iso_c && expr->ts.u.derived)
4260 gfc_symbol *derived = expr->ts.u.derived;
4262 /* The derived symbol has already been converted to a (void *). Use
4264 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4265 expr->ts.f90_type = derived->ts.f90_type;
4267 gfc_init_se (&se, NULL);
4268 gfc_conv_constant (&se, expr);
4269 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4273 if (array && !procptr)
4276 /* Arrays need special handling. */
4278 ctor = gfc_build_null_descriptor (type);
4279 /* Special case assigning an array to zero. */
4280 else if (is_zero_initializer_p (expr))
4281 ctor = build_constructor (type, NULL);
4283 ctor = gfc_conv_array_initializer (type, expr);
4284 TREE_STATIC (ctor) = 1;
4287 else if (pointer || procptr)
4289 if (!expr || expr->expr_type == EXPR_NULL)
4290 return fold_convert (type, null_pointer_node);
4293 gfc_init_se (&se, NULL);
4294 se.want_pointer = 1;
4295 gfc_conv_expr (&se, expr);
4296 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4306 gfc_init_se (&se, NULL);
4307 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4308 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4310 gfc_conv_structure (&se, expr, 1);
4311 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4312 TREE_STATIC (se.expr) = 1;
4317 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4318 TREE_STATIC (ctor) = 1;
4323 gfc_init_se (&se, NULL);
4324 gfc_conv_constant (&se, expr);
4325 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4332 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4344 gfc_start_block (&block);
4346 /* Initialize the scalarizer. */
4347 gfc_init_loopinfo (&loop);
4349 gfc_init_se (&lse, NULL);
4350 gfc_init_se (&rse, NULL);
4353 rss = gfc_walk_expr (expr);
4354 if (rss == gfc_ss_terminator)
4355 /* The rhs is scalar. Add a ss for the expression. */
4356 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4358 /* Create a SS for the destination. */
4359 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4361 lss->shape = gfc_get_shape (cm->as->rank);
4362 lss->data.info.descriptor = dest;
4363 lss->data.info.data = gfc_conv_array_data (dest);
4364 lss->data.info.offset = gfc_conv_array_offset (dest);
4365 for (n = 0; n < cm->as->rank; n++)
4367 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4368 lss->data.info.stride[n] = gfc_index_one_node;
4370 mpz_init (lss->shape[n]);
4371 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4372 cm->as->lower[n]->value.integer);
4373 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4376 /* Associate the SS with the loop. */
4377 gfc_add_ss_to_loop (&loop, lss);
4378 gfc_add_ss_to_loop (&loop, rss);
4380 /* Calculate the bounds of the scalarization. */
4381 gfc_conv_ss_startstride (&loop);
4383 /* Setup the scalarizing loops. */
4384 gfc_conv_loop_setup (&loop, &expr->where);
4386 /* Setup the gfc_se structures. */
4387 gfc_copy_loopinfo_to_se (&lse, &loop);
4388 gfc_copy_loopinfo_to_se (&rse, &loop);
4391 gfc_mark_ss_chain_used (rss, 1);
4393 gfc_mark_ss_chain_used (lss, 1);
4395 /* Start the scalarized loop body. */
4396 gfc_start_scalarized_body (&loop, &body);
4398 gfc_conv_tmp_array_ref (&lse);
4399 if (cm->ts.type == BT_CHARACTER)
4400 lse.string_length = cm->ts.u.cl->backend_decl;
4402 gfc_conv_expr (&rse, expr);
4404 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4405 gfc_add_expr_to_block (&body, tmp);
4407 gcc_assert (rse.ss == gfc_ss_terminator);
4409 /* Generate the copying loops. */
4410 gfc_trans_scalarizing_loops (&loop, &body);
4412 /* Wrap the whole thing up. */
4413 gfc_add_block_to_block (&block, &loop.pre);
4414 gfc_add_block_to_block (&block, &loop.post);
4416 gcc_assert (lss->shape != NULL);
4417 gfc_free_shape (&lss->shape, cm->as->rank);
4418 gfc_cleanup_loop (&loop);
4420 return gfc_finish_block (&block);
4425 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4436 gfc_expr *arg = NULL;
4438 gfc_start_block (&block);
4439 gfc_init_se (&se, NULL);
4441 /* Get the descriptor for the expressions. */
4442 rss = gfc_walk_expr (expr);
4443 se.want_pointer = 0;
4444 gfc_conv_expr_descriptor (&se, expr, rss);
4445 gfc_add_block_to_block (&block, &se.pre);
4446 gfc_add_modify (&block, dest, se.expr);
4448 /* Deal with arrays of derived types with allocatable components. */
4449 if (cm->ts.type == BT_DERIVED
4450 && cm->ts.u.derived->attr.alloc_comp)
4451 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4455 tmp = gfc_duplicate_allocatable (dest, se.expr,
4456 TREE_TYPE(cm->backend_decl),
4459 gfc_add_expr_to_block (&block, tmp);
4460 gfc_add_block_to_block (&block, &se.post);
4462 if (expr->expr_type != EXPR_VARIABLE)
4463 gfc_conv_descriptor_data_set (&block, se.expr,
4466 /* We need to know if the argument of a conversion function is a
4467 variable, so that the correct lower bound can be used. */
4468 if (expr->expr_type == EXPR_FUNCTION
4469 && expr->value.function.isym
4470 && expr->value.function.isym->conversion
4471 && expr->value.function.actual->expr
4472 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4473 arg = expr->value.function.actual->expr;
4475 /* Obtain the array spec of full array references. */
4477 as = gfc_get_full_arrayspec_from_expr (arg);
4479 as = gfc_get_full_arrayspec_from_expr (expr);
4481 /* Shift the lbound and ubound of temporaries to being unity,
4482 rather than zero, based. Always calculate the offset. */
4483 offset = gfc_conv_descriptor_offset_get (dest);
4484 gfc_add_modify (&block, offset, gfc_index_zero_node);
4485 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4487 for (n = 0; n < expr->rank; n++)
4492 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4493 TODO It looks as if gfc_conv_expr_descriptor should return
4494 the correct bounds and that the following should not be
4495 necessary. This would simplify gfc_conv_intrinsic_bound
4497 if (as && as->lower[n])
4500 gfc_init_se (&lbse, NULL);
4501 gfc_conv_expr (&lbse, as->lower[n]);
4502 gfc_add_block_to_block (&block, &lbse.pre);
4503 lbound = gfc_evaluate_now (lbse.expr, &block);
4507 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4508 lbound = gfc_conv_descriptor_lbound_get (tmp,
4512 lbound = gfc_conv_descriptor_lbound_get (dest,
4515 lbound = gfc_index_one_node;
4517 lbound = fold_convert (gfc_array_index_type, lbound);
4519 /* Shift the bounds and set the offset accordingly. */
4520 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4521 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4522 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4523 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4525 gfc_conv_descriptor_ubound_set (&block, dest,
4526 gfc_rank_cst[n], tmp);
4527 gfc_conv_descriptor_lbound_set (&block, dest,
4528 gfc_rank_cst[n], lbound);
4530 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4531 gfc_conv_descriptor_lbound_get (dest,
4533 gfc_conv_descriptor_stride_get (dest,
4535 gfc_add_modify (&block, tmp2, tmp);
4536 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4538 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4543 /* If a conversion expression has a null data pointer
4544 argument, nullify the allocatable component. */
4548 if (arg->symtree->n.sym->attr.allocatable
4549 || arg->symtree->n.sym->attr.pointer)
4551 non_null_expr = gfc_finish_block (&block);
4552 gfc_start_block (&block);
4553 gfc_conv_descriptor_data_set (&block, dest,
4555 null_expr = gfc_finish_block (&block);
4556 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4557 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4558 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4559 return build3_v (COND_EXPR, tmp,
4560 null_expr, non_null_expr);
4564 return gfc_finish_block (&block);
4568 /* Assign a single component of a derived type constructor. */
4571 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4579 gfc_start_block (&block);
4581 if (cm->attr.pointer)
4583 gfc_init_se (&se, NULL);
4584 /* Pointer component. */
4585 if (cm->attr.dimension)
4587 /* Array pointer. */
4588 if (expr->expr_type == EXPR_NULL)
4589 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4592 rss = gfc_walk_expr (expr);
4593 se.direct_byref = 1;
4595 gfc_conv_expr_descriptor (&se, expr, rss);
4596 gfc_add_block_to_block (&block, &se.pre);
4597 gfc_add_block_to_block (&block, &se.post);
4602 /* Scalar pointers. */
4603 se.want_pointer = 1;
4604 gfc_conv_expr (&se, expr);
4605 gfc_add_block_to_block (&block, &se.pre);
4606 gfc_add_modify (&block, dest,
4607 fold_convert (TREE_TYPE (dest), se.expr));
4608 gfc_add_block_to_block (&block, &se.post);
4611 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4613 /* NULL initialization for CLASS components. */
4614 tmp = gfc_trans_structure_assign (dest,
4615 gfc_class_null_initializer (&cm->ts));
4616 gfc_add_expr_to_block (&block, tmp);
4618 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4620 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4621 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4622 else if (cm->attr.allocatable)
4624 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4625 gfc_add_expr_to_block (&block, tmp);
4629 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4630 gfc_add_expr_to_block (&block, tmp);
4633 else if (expr->ts.type == BT_DERIVED)
4635 if (expr->expr_type != EXPR_STRUCTURE)
4637 gfc_init_se (&se, NULL);
4638 gfc_conv_expr (&se, expr);
4639 gfc_add_block_to_block (&block, &se.pre);
4640 gfc_add_modify (&block, dest,
4641 fold_convert (TREE_TYPE (dest), se.expr));
4642 gfc_add_block_to_block (&block, &se.post);
4646 /* Nested constructors. */
4647 tmp = gfc_trans_structure_assign (dest, expr);
4648 gfc_add_expr_to_block (&block, tmp);
4653 /* Scalar component. */
4654 gfc_init_se (&se, NULL);
4655 gfc_init_se (&lse, NULL);
4657 gfc_conv_expr (&se, expr);
4658 if (cm->ts.type == BT_CHARACTER)
4659 lse.string_length = cm->ts.u.cl->backend_decl;
4661 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4662 gfc_add_expr_to_block (&block, tmp);
4664 return gfc_finish_block (&block);
4667 /* Assign a derived type constructor to a variable. */
4670 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4678 gfc_start_block (&block);
4679 cm = expr->ts.u.derived->components;
4681 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4682 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4683 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4687 gcc_assert (cm->backend_decl == NULL);
4688 gfc_init_se (&se, NULL);
4689 gfc_init_se (&lse, NULL);
4690 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4692 gfc_add_modify (&block, lse.expr,
4693 fold_convert (TREE_TYPE (lse.expr), se.expr));
4695 return gfc_finish_block (&block);
4698 for (c = gfc_constructor_first (expr->value.constructor);
4699 c; c = gfc_constructor_next (c), cm = cm->next)
4701 /* Skip absent members in default initializers. */
4705 field = cm->backend_decl;
4706 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4707 dest, field, NULL_TREE);
4708 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4709 gfc_add_expr_to_block (&block, tmp);
4711 return gfc_finish_block (&block);
4714 /* Build an expression for a constructor. If init is nonzero then
4715 this is part of a static variable initializer. */
4718 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4725 VEC(constructor_elt,gc) *v = NULL;
4727 gcc_assert (se->ss == NULL);
4728 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4729 type = gfc_typenode_for_spec (&expr->ts);
4733 /* Create a temporary variable and fill it in. */
4734 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4735 tmp = gfc_trans_structure_assign (se->expr, expr);
4736 gfc_add_expr_to_block (&se->pre, tmp);
4740 cm = expr->ts.u.derived->components;
4742 for (c = gfc_constructor_first (expr->value.constructor);
4743 c; c = gfc_constructor_next (c), cm = cm->next)
4745 /* Skip absent members in default initializers and allocatable
4746 components. Although the latter have a default initializer
4747 of EXPR_NULL,... by default, the static nullify is not needed
4748 since this is done every time we come into scope. */
4749 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4752 if (strcmp (cm->name, "_size") == 0)
4754 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4755 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4757 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4758 && strcmp (cm->name, "_extends") == 0)
4762 vtabs = cm->initializer->symtree->n.sym;
4763 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4764 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4768 val = gfc_conv_initializer (c->expr, &cm->ts,
4769 TREE_TYPE (cm->backend_decl),
4770 cm->attr.dimension, cm->attr.pointer,
4771 cm->attr.proc_pointer);
4773 /* Append it to the constructor list. */
4774 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4777 se->expr = build_constructor (type, v);
4779 TREE_CONSTANT (se->expr) = 1;
4783 /* Translate a substring expression. */
4786 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4792 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4794 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4795 expr->value.character.length,
4796 expr->value.character.string);
4798 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4799 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4802 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4806 /* Entry point for expression translation. Evaluates a scalar quantity.
4807 EXPR is the expression to be translated, and SE is the state structure if
4808 called from within the scalarized. */
4811 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4813 if (se->ss && se->ss->expr == expr
4814 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4816 /* Substitute a scalar expression evaluated outside the scalarization
4818 se->expr = se->ss->data.scalar.expr;
4819 if (se->ss->type == GFC_SS_REFERENCE)
4820 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4821 se->string_length = se->ss->string_length;
4822 gfc_advance_se_ss_chain (se);
4826 /* We need to convert the expressions for the iso_c_binding derived types.
4827 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4828 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4829 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4830 updated to be an integer with a kind equal to the size of a (void *). */
4831 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4832 && expr->ts.u.derived->attr.is_iso_c)
4834 if (expr->expr_type == EXPR_VARIABLE
4835 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4836 || expr->symtree->n.sym->intmod_sym_id
4837 == ISOCBINDING_NULL_FUNPTR))
4839 /* Set expr_type to EXPR_NULL, which will result in
4840 null_pointer_node being used below. */
4841 expr->expr_type = EXPR_NULL;
4845 /* Update the type/kind of the expression to be what the new
4846 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4847 expr->ts.type = expr->ts.u.derived->ts.type;
4848 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4849 expr->ts.kind = expr->ts.u.derived->ts.kind;
4853 switch (expr->expr_type)
4856 gfc_conv_expr_op (se, expr);
4860 gfc_conv_function_expr (se, expr);
4864 gfc_conv_constant (se, expr);
4868 gfc_conv_variable (se, expr);
4872 se->expr = null_pointer_node;
4875 case EXPR_SUBSTRING:
4876 gfc_conv_substring_expr (se, expr);
4879 case EXPR_STRUCTURE:
4880 gfc_conv_structure (se, expr, 0);
4884 gfc_conv_array_constructor_expr (se, expr);
4893 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4894 of an assignment. */
4896 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4898 gfc_conv_expr (se, expr);
4899 /* All numeric lvalues should have empty post chains. If not we need to
4900 figure out a way of rewriting an lvalue so that it has no post chain. */
4901 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4904 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4905 numeric expressions. Used for scalar values where inserting cleanup code
4908 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4912 gcc_assert (expr->ts.type != BT_CHARACTER);
4913 gfc_conv_expr (se, expr);
4916 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4917 gfc_add_modify (&se->pre, val, se->expr);
4919 gfc_add_block_to_block (&se->pre, &se->post);
4923 /* Helper to translate an expression and convert it to a particular type. */
4925 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4927 gfc_conv_expr_val (se, expr);
4928 se->expr = convert (type, se->expr);
4932 /* Converts an expression so that it can be passed by reference. Scalar
4936 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4940 if (se->ss && se->ss->expr == expr
4941 && se->ss->type == GFC_SS_REFERENCE)
4943 /* Returns a reference to the scalar evaluated outside the loop
4945 gfc_conv_expr (se, expr);
4949 if (expr->ts.type == BT_CHARACTER)
4951 gfc_conv_expr (se, expr);
4952 gfc_conv_string_parameter (se);
4956 if (expr->expr_type == EXPR_VARIABLE)
4958 se->want_pointer = 1;
4959 gfc_conv_expr (se, expr);
4962 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4963 gfc_add_modify (&se->pre, var, se->expr);
4964 gfc_add_block_to_block (&se->pre, &se->post);
4970 if (expr->expr_type == EXPR_FUNCTION
4971 && ((expr->value.function.esym
4972 && expr->value.function.esym->result->attr.pointer
4973 && !expr->value.function.esym->result->attr.dimension)
4974 || (!expr->value.function.esym
4975 && expr->symtree->n.sym->attr.pointer
4976 && !expr->symtree->n.sym->attr.dimension)))
4978 se->want_pointer = 1;
4979 gfc_conv_expr (se, expr);
4980 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4981 gfc_add_modify (&se->pre, var, se->expr);
4987 gfc_conv_expr (se, expr);
4989 /* Create a temporary var to hold the value. */
4990 if (TREE_CONSTANT (se->expr))
4992 tree tmp = se->expr;
4993 STRIP_TYPE_NOPS (tmp);
4994 var = build_decl (input_location,
4995 CONST_DECL, NULL, TREE_TYPE (tmp));
4996 DECL_INITIAL (var) = tmp;
4997 TREE_STATIC (var) = 1;
5002 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5003 gfc_add_modify (&se->pre, var, se->expr);
5005 gfc_add_block_to_block (&se->pre, &se->post);
5007 /* Take the address of that value. */
5008 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5013 gfc_trans_pointer_assign (gfc_code * code)
5015 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5019 /* Generate code for a pointer assignment. */
5022 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5033 gfc_start_block (&block);
5035 gfc_init_se (&lse, NULL);
5037 lss = gfc_walk_expr (expr1);
5038 rss = gfc_walk_expr (expr2);
5039 if (lss == gfc_ss_terminator)
5041 /* Scalar pointers. */
5042 lse.want_pointer = 1;
5043 gfc_conv_expr (&lse, expr1);
5044 gcc_assert (rss == gfc_ss_terminator);
5045 gfc_init_se (&rse, NULL);
5046 rse.want_pointer = 1;
5047 gfc_conv_expr (&rse, expr2);
5049 if (expr1->symtree->n.sym->attr.proc_pointer
5050 && expr1->symtree->n.sym->attr.dummy)
5051 lse.expr = build_fold_indirect_ref_loc (input_location,
5054 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5055 && expr2->symtree->n.sym->attr.dummy)
5056 rse.expr = build_fold_indirect_ref_loc (input_location,
5059 gfc_add_block_to_block (&block, &lse.pre);
5060 gfc_add_block_to_block (&block, &rse.pre);
5062 /* Check character lengths if character expression. The test is only
5063 really added if -fbounds-check is enabled. Exclude deferred
5064 character length lefthand sides. */
5065 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5066 && !(expr1->ts.deferred
5067 && (TREE_CODE (lse.string_length) == VAR_DECL))
5068 && !expr1->symtree->n.sym->attr.proc_pointer
5069 && !gfc_is_proc_ptr_comp (expr1, NULL))
5071 gcc_assert (expr2->ts.type == BT_CHARACTER);
5072 gcc_assert (lse.string_length && rse.string_length);
5073 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5074 lse.string_length, rse.string_length,
5078 /* The assignment to an deferred character length sets the string
5079 length to that of the rhs. */
5080 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5082 if (expr2->expr_type != EXPR_NULL)
5083 gfc_add_modify (&block, lse.string_length, rse.string_length);
5085 gfc_add_modify (&block, lse.string_length,
5086 build_int_cst (gfc_charlen_type_node, 0));
5089 gfc_add_modify (&block, lse.expr,
5090 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5092 gfc_add_block_to_block (&block, &rse.post);
5093 gfc_add_block_to_block (&block, &lse.post);
5100 tree strlen_rhs = NULL_TREE;
5102 /* Array pointer. Find the last reference on the LHS and if it is an
5103 array section ref, we're dealing with bounds remapping. In this case,
5104 set it to AR_FULL so that gfc_conv_expr_descriptor does
5105 not see it and process the bounds remapping afterwards explicitely. */
5106 for (remap = expr1->ref; remap; remap = remap->next)
5107 if (!remap->next && remap->type == REF_ARRAY
5108 && remap->u.ar.type == AR_SECTION)
5110 remap->u.ar.type = AR_FULL;
5113 rank_remap = (remap && remap->u.ar.end[0]);
5115 gfc_conv_expr_descriptor (&lse, expr1, lss);
5116 strlen_lhs = lse.string_length;
5119 if (expr2->expr_type == EXPR_NULL)
5121 /* Just set the data pointer to null. */
5122 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5124 else if (rank_remap)
5126 /* If we are rank-remapping, just get the RHS's descriptor and
5127 process this later on. */
5128 gfc_init_se (&rse, NULL);
5129 rse.direct_byref = 1;
5130 rse.byref_noassign = 1;
5131 gfc_conv_expr_descriptor (&rse, expr2, rss);
5132 strlen_rhs = rse.string_length;
5134 else if (expr2->expr_type == EXPR_VARIABLE)
5136 /* Assign directly to the LHS's descriptor. */
5137 lse.direct_byref = 1;
5138 gfc_conv_expr_descriptor (&lse, expr2, rss);
5139 strlen_rhs = lse.string_length;
5141 /* If this is a subreference array pointer assignment, use the rhs
5142 descriptor element size for the lhs span. */
5143 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5145 decl = expr1->symtree->n.sym->backend_decl;
5146 gfc_init_se (&rse, NULL);
5147 rse.descriptor_only = 1;
5148 gfc_conv_expr (&rse, expr2);
5149 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5150 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5151 if (!INTEGER_CST_P (tmp))
5152 gfc_add_block_to_block (&lse.post, &rse.pre);
5153 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5158 /* Assign to a temporary descriptor and then copy that
5159 temporary to the pointer. */
5160 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5163 lse.direct_byref = 1;
5164 gfc_conv_expr_descriptor (&lse, expr2, rss);
5165 strlen_rhs = lse.string_length;
5166 gfc_add_modify (&lse.pre, desc, tmp);
5169 gfc_add_block_to_block (&block, &lse.pre);
5171 gfc_add_block_to_block (&block, &rse.pre);
5173 /* If we do bounds remapping, update LHS descriptor accordingly. */
5177 gcc_assert (remap->u.ar.dimen == expr1->rank);
5181 /* Do rank remapping. We already have the RHS's descriptor
5182 converted in rse and now have to build the correct LHS
5183 descriptor for it. */
5187 tree lbound, ubound;
5190 dtype = gfc_conv_descriptor_dtype (desc);
5191 tmp = gfc_get_dtype (TREE_TYPE (desc));
5192 gfc_add_modify (&block, dtype, tmp);
5194 /* Copy data pointer. */
5195 data = gfc_conv_descriptor_data_get (rse.expr);
5196 gfc_conv_descriptor_data_set (&block, desc, data);
5198 /* Copy offset but adjust it such that it would correspond
5199 to a lbound of zero. */
5200 offs = gfc_conv_descriptor_offset_get (rse.expr);
5201 for (dim = 0; dim < expr2->rank; ++dim)
5203 stride = gfc_conv_descriptor_stride_get (rse.expr,
5205 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5207 tmp = fold_build2_loc (input_location, MULT_EXPR,
5208 gfc_array_index_type, stride, lbound);
5209 offs = fold_build2_loc (input_location, PLUS_EXPR,
5210 gfc_array_index_type, offs, tmp);
5212 gfc_conv_descriptor_offset_set (&block, desc, offs);
5214 /* Set the bounds as declared for the LHS and calculate strides as
5215 well as another offset update accordingly. */
5216 stride = gfc_conv_descriptor_stride_get (rse.expr,
5218 for (dim = 0; dim < expr1->rank; ++dim)
5223 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5225 /* Convert declared bounds. */
5226 gfc_init_se (&lower_se, NULL);
5227 gfc_init_se (&upper_se, NULL);
5228 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5229 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5231 gfc_add_block_to_block (&block, &lower_se.pre);
5232 gfc_add_block_to_block (&block, &upper_se.pre);
5234 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5235 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5237 lbound = gfc_evaluate_now (lbound, &block);
5238 ubound = gfc_evaluate_now (ubound, &block);
5240 gfc_add_block_to_block (&block, &lower_se.post);
5241 gfc_add_block_to_block (&block, &upper_se.post);
5243 /* Set bounds in descriptor. */
5244 gfc_conv_descriptor_lbound_set (&block, desc,
5245 gfc_rank_cst[dim], lbound);
5246 gfc_conv_descriptor_ubound_set (&block, desc,
5247 gfc_rank_cst[dim], ubound);
5250 stride = gfc_evaluate_now (stride, &block);
5251 gfc_conv_descriptor_stride_set (&block, desc,
5252 gfc_rank_cst[dim], stride);
5254 /* Update offset. */
5255 offs = gfc_conv_descriptor_offset_get (desc);
5256 tmp = fold_build2_loc (input_location, MULT_EXPR,
5257 gfc_array_index_type, lbound, stride);
5258 offs = fold_build2_loc (input_location, MINUS_EXPR,
5259 gfc_array_index_type, offs, tmp);
5260 offs = gfc_evaluate_now (offs, &block);
5261 gfc_conv_descriptor_offset_set (&block, desc, offs);
5263 /* Update stride. */
5264 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5265 stride = fold_build2_loc (input_location, MULT_EXPR,
5266 gfc_array_index_type, stride, tmp);
5271 /* Bounds remapping. Just shift the lower bounds. */
5273 gcc_assert (expr1->rank == expr2->rank);
5275 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5279 gcc_assert (remap->u.ar.start[dim]);
5280 gcc_assert (!remap->u.ar.end[dim]);
5281 gfc_init_se (&lbound_se, NULL);
5282 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5284 gfc_add_block_to_block (&block, &lbound_se.pre);
5285 gfc_conv_shift_descriptor_lbound (&block, desc,
5286 dim, lbound_se.expr);
5287 gfc_add_block_to_block (&block, &lbound_se.post);
5292 /* Check string lengths if applicable. The check is only really added
5293 to the output code if -fbounds-check is enabled. */
5294 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5296 gcc_assert (expr2->ts.type == BT_CHARACTER);
5297 gcc_assert (strlen_lhs && strlen_rhs);
5298 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5299 strlen_lhs, strlen_rhs, &block);
5302 /* If rank remapping was done, check with -fcheck=bounds that
5303 the target is at least as large as the pointer. */
5304 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5310 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5311 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5313 lsize = gfc_evaluate_now (lsize, &block);
5314 rsize = gfc_evaluate_now (rsize, &block);
5315 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5318 msg = _("Target of rank remapping is too small (%ld < %ld)");
5319 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5323 gfc_add_block_to_block (&block, &lse.post);
5325 gfc_add_block_to_block (&block, &rse.post);
5328 return gfc_finish_block (&block);
5332 /* Makes sure se is suitable for passing as a function string parameter. */
5333 /* TODO: Need to check all callers of this function. It may be abused. */
5336 gfc_conv_string_parameter (gfc_se * se)
5340 if (TREE_CODE (se->expr) == STRING_CST)
5342 type = TREE_TYPE (TREE_TYPE (se->expr));
5343 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5347 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5349 if (TREE_CODE (se->expr) != INDIRECT_REF)
5351 type = TREE_TYPE (se->expr);
5352 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5356 type = gfc_get_character_type_len (gfc_default_character_kind,
5358 type = build_pointer_type (type);
5359 se->expr = gfc_build_addr_expr (type, se->expr);
5363 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5367 /* Generate code for assignment of scalar variables. Includes character
5368 strings and derived types with allocatable components.
5369 If you know that the LHS has no allocations, set dealloc to false. */
5372 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5373 bool l_is_temp, bool r_is_var, bool dealloc)
5379 gfc_init_block (&block);
5381 if (ts.type == BT_CHARACTER)
5386 if (lse->string_length != NULL_TREE)
5388 gfc_conv_string_parameter (lse);
5389 gfc_add_block_to_block (&block, &lse->pre);
5390 llen = lse->string_length;
5393 if (rse->string_length != NULL_TREE)
5395 gcc_assert (rse->string_length != NULL_TREE);
5396 gfc_conv_string_parameter (rse);
5397 gfc_add_block_to_block (&block, &rse->pre);
5398 rlen = rse->string_length;
5401 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5402 rse->expr, ts.kind);
5404 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5408 /* Are the rhs and the lhs the same? */
5411 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5412 gfc_build_addr_expr (NULL_TREE, lse->expr),
5413 gfc_build_addr_expr (NULL_TREE, rse->expr));
5414 cond = gfc_evaluate_now (cond, &lse->pre);
5417 /* Deallocate the lhs allocated components as long as it is not
5418 the same as the rhs. This must be done following the assignment
5419 to prevent deallocating data that could be used in the rhs
5421 if (!l_is_temp && dealloc)
5423 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5424 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5426 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5428 gfc_add_expr_to_block (&lse->post, tmp);
5431 gfc_add_block_to_block (&block, &rse->pre);
5432 gfc_add_block_to_block (&block, &lse->pre);
5434 gfc_add_modify (&block, lse->expr,
5435 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5437 /* Do a deep copy if the rhs is a variable, if it is not the
5441 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5442 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5444 gfc_add_expr_to_block (&block, tmp);
5447 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5449 gfc_add_block_to_block (&block, &lse->pre);
5450 gfc_add_block_to_block (&block, &rse->pre);
5451 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5452 TREE_TYPE (lse->expr), rse->expr);
5453 gfc_add_modify (&block, lse->expr, tmp);
5457 gfc_add_block_to_block (&block, &lse->pre);
5458 gfc_add_block_to_block (&block, &rse->pre);
5460 gfc_add_modify (&block, lse->expr,
5461 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5464 gfc_add_block_to_block (&block, &lse->post);
5465 gfc_add_block_to_block (&block, &rse->post);
5467 return gfc_finish_block (&block);
5471 /* There are quite a lot of restrictions on the optimisation in using an
5472 array function assign without a temporary. */
5475 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5478 bool seen_array_ref;
5480 gfc_symbol *sym = expr1->symtree->n.sym;
5482 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5483 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5486 /* Elemental functions are scalarized so that they don't need a
5487 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5488 they would need special treatment in gfc_trans_arrayfunc_assign. */
5489 if (expr2->value.function.esym != NULL
5490 && expr2->value.function.esym->attr.elemental)
5493 /* Need a temporary if rhs is not FULL or a contiguous section. */
5494 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5497 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5498 if (gfc_ref_needs_temporary_p (expr1->ref))
5501 /* Functions returning pointers or allocatables need temporaries. */
5502 c = expr2->value.function.esym
5503 ? (expr2->value.function.esym->attr.pointer
5504 || expr2->value.function.esym->attr.allocatable)
5505 : (expr2->symtree->n.sym->attr.pointer
5506 || expr2->symtree->n.sym->attr.allocatable);
5510 /* Character array functions need temporaries unless the
5511 character lengths are the same. */
5512 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5514 if (expr1->ts.u.cl->length == NULL
5515 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5518 if (expr2->ts.u.cl->length == NULL
5519 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5522 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5523 expr2->ts.u.cl->length->value.integer) != 0)
5527 /* Check that no LHS component references appear during an array
5528 reference. This is needed because we do not have the means to
5529 span any arbitrary stride with an array descriptor. This check
5530 is not needed for the rhs because the function result has to be
5532 seen_array_ref = false;
5533 for (ref = expr1->ref; ref; ref = ref->next)
5535 if (ref->type == REF_ARRAY)
5536 seen_array_ref= true;
5537 else if (ref->type == REF_COMPONENT && seen_array_ref)
5541 /* Check for a dependency. */
5542 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5543 expr2->value.function.esym,
5544 expr2->value.function.actual,
5548 /* If we have reached here with an intrinsic function, we do not
5549 need a temporary except in the particular case that reallocation
5550 on assignment is active and the lhs is allocatable and a target. */
5551 if (expr2->value.function.isym)
5552 return (gfc_option.flag_realloc_lhs
5553 && sym->attr.allocatable
5554 && sym->attr.target);
5556 /* If the LHS is a dummy, we need a temporary if it is not
5558 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5561 /* If the lhs has been host_associated, is in common, a pointer or is
5562 a target and the function is not using a RESULT variable, aliasing
5563 can occur and a temporary is needed. */
5564 if ((sym->attr.host_assoc
5565 || sym->attr.in_common
5566 || sym->attr.pointer
5567 || sym->attr.cray_pointee
5568 || sym->attr.target)
5569 && expr2->symtree != NULL
5570 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5573 /* A PURE function can unconditionally be called without a temporary. */
5574 if (expr2->value.function.esym != NULL
5575 && expr2->value.function.esym->attr.pure)
5578 /* Implicit_pure functions are those which could legally be declared
5580 if (expr2->value.function.esym != NULL
5581 && expr2->value.function.esym->attr.implicit_pure)
5584 if (!sym->attr.use_assoc
5585 && !sym->attr.in_common
5586 && !sym->attr.pointer
5587 && !sym->attr.target
5588 && !sym->attr.cray_pointee
5589 && expr2->value.function.esym)
5591 /* A temporary is not needed if the function is not contained and
5592 the variable is local or host associated and not a pointer or
5594 if (!expr2->value.function.esym->attr.contained)
5597 /* A temporary is not needed if the lhs has never been host
5598 associated and the procedure is contained. */
5599 else if (!sym->attr.host_assoc)
5602 /* A temporary is not needed if the variable is local and not
5603 a pointer, a target or a result. */
5605 && expr2->value.function.esym->ns == sym->ns->parent)
5609 /* Default to temporary use. */
5614 /* Provide the loop info so that the lhs descriptor can be built for
5615 reallocatable assignments from extrinsic function calls. */
5618 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5621 /* Signal that the function call should not be made by
5622 gfc_conv_loop_setup. */
5623 se->ss->is_alloc_lhs = 1;
5624 gfc_init_loopinfo (loop);
5625 gfc_add_ss_to_loop (loop, *ss);
5626 gfc_add_ss_to_loop (loop, se->ss);
5627 gfc_conv_ss_startstride (loop);
5628 gfc_conv_loop_setup (loop, where);
5629 gfc_copy_loopinfo_to_se (se, loop);
5630 gfc_add_block_to_block (&se->pre, &loop->pre);
5631 gfc_add_block_to_block (&se->pre, &loop->post);
5632 se->ss->is_alloc_lhs = 0;
5636 /* For Assignment to a reallocatable lhs from intrinsic functions,
5637 replace the se.expr (ie. the result) with a temporary descriptor.
5638 Null the data field so that the library allocates space for the
5639 result. Free the data of the original descriptor after the function,
5640 in case it appears in an argument expression and transfer the
5641 result to the original descriptor. */
5644 fcncall_realloc_result (gfc_se *se, int rank)
5652 /* Use the allocation done by the library. Substitute the lhs
5653 descriptor with a copy, whose data field is nulled.*/
5654 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5655 /* Unallocated, the descriptor does not have a dtype. */
5656 tmp = gfc_conv_descriptor_dtype (desc);
5657 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5658 res_desc = gfc_evaluate_now (desc, &se->pre);
5659 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5660 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5662 /* Free the lhs after the function call and copy the result to
5663 the lhs descriptor. */
5664 tmp = gfc_conv_descriptor_data_get (desc);
5665 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5666 gfc_add_expr_to_block (&se->post, tmp);
5667 gfc_add_modify (&se->post, desc, res_desc);
5669 offset = gfc_index_zero_node;
5670 tmp = gfc_index_one_node;
5671 /* Now reset the bounds from zero based to unity based. */
5672 for (n = 0 ; n < rank; n++)
5674 /* Accumulate the offset. */
5675 offset = fold_build2_loc (input_location, MINUS_EXPR,
5676 gfc_array_index_type,
5678 /* Now do the bounds. */
5679 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5680 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5681 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5682 gfc_array_index_type,
5683 tmp, gfc_index_one_node);
5684 gfc_conv_descriptor_lbound_set (&se->post, desc,
5686 gfc_index_one_node);
5687 gfc_conv_descriptor_ubound_set (&se->post, desc,
5688 gfc_rank_cst[n], tmp);
5690 /* The extent for the next contribution to offset. */
5691 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5692 gfc_array_index_type,
5693 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5694 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5695 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5696 gfc_array_index_type,
5697 tmp, gfc_index_one_node);
5699 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5704 /* Try to translate array(:) = func (...), where func is a transformational
5705 array function, without using a temporary. Returns NULL if this isn't the
5709 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5713 gfc_component *comp = NULL;
5716 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5719 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5721 gcc_assert (expr2->value.function.isym
5722 || (gfc_is_proc_ptr_comp (expr2, &comp)
5723 && comp && comp->attr.dimension)
5724 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5725 && expr2->value.function.esym->result->attr.dimension));
5727 ss = gfc_walk_expr (expr1);
5728 gcc_assert (ss != gfc_ss_terminator);
5729 gfc_init_se (&se, NULL);
5730 gfc_start_block (&se.pre);
5731 se.want_pointer = 1;
5733 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5735 if (expr1->ts.type == BT_DERIVED
5736 && expr1->ts.u.derived->attr.alloc_comp)
5739 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5741 gfc_add_expr_to_block (&se.pre, tmp);
5744 se.direct_byref = 1;
5745 se.ss = gfc_walk_expr (expr2);
5746 gcc_assert (se.ss != gfc_ss_terminator);
5748 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5749 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5750 Clearly, this cannot be done for an allocatable function result, since
5751 the shape of the result is unknown and, in any case, the function must
5752 correctly take care of the reallocation internally. For intrinsic
5753 calls, the array data is freed and the library takes care of allocation.
5754 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5756 if (gfc_option.flag_realloc_lhs
5757 && gfc_is_reallocatable_lhs (expr1)
5758 && !gfc_expr_attr (expr1).codimension
5759 && !gfc_is_coindexed (expr1)
5760 && !(expr2->value.function.esym
5761 && expr2->value.function.esym->result->attr.allocatable))
5763 if (!expr2->value.function.isym)
5765 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5766 ss->is_alloc_lhs = 1;
5769 fcncall_realloc_result (&se, expr1->rank);
5772 gfc_conv_function_expr (&se, expr2);
5773 gfc_add_block_to_block (&se.pre, &se.post);
5775 return gfc_finish_block (&se.pre);
5779 /* Try to efficiently translate array(:) = 0. Return NULL if this
5783 gfc_trans_zero_assign (gfc_expr * expr)
5785 tree dest, len, type;
5789 sym = expr->symtree->n.sym;
5790 dest = gfc_get_symbol_decl (sym);
5792 type = TREE_TYPE (dest);
5793 if (POINTER_TYPE_P (type))
5794 type = TREE_TYPE (type);
5795 if (!GFC_ARRAY_TYPE_P (type))
5798 /* Determine the length of the array. */
5799 len = GFC_TYPE_ARRAY_SIZE (type);
5800 if (!len || TREE_CODE (len) != INTEGER_CST)
5803 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5804 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5805 fold_convert (gfc_array_index_type, tmp));
5807 /* If we are zeroing a local array avoid taking its address by emitting
5809 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5810 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5811 dest, build_constructor (TREE_TYPE (dest), NULL));
5813 /* Convert arguments to the correct types. */
5814 dest = fold_convert (pvoid_type_node, dest);
5815 len = fold_convert (size_type_node, len);
5817 /* Construct call to __builtin_memset. */
5818 tmp = build_call_expr_loc (input_location,
5819 built_in_decls[BUILT_IN_MEMSET],
5820 3, dest, integer_zero_node, len);
5821 return fold_convert (void_type_node, tmp);
5825 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5826 that constructs the call to __builtin_memcpy. */
5829 gfc_build_memcpy_call (tree dst, tree src, tree len)
5833 /* Convert arguments to the correct types. */
5834 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5835 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5837 dst = fold_convert (pvoid_type_node, dst);
5839 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5840 src = gfc_build_addr_expr (pvoid_type_node, src);
5842 src = fold_convert (pvoid_type_node, src);
5844 len = fold_convert (size_type_node, len);
5846 /* Construct call to __builtin_memcpy. */
5847 tmp = build_call_expr_loc (input_location,
5848 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5849 return fold_convert (void_type_node, tmp);
5853 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5854 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5855 source/rhs, both are gfc_full_array_ref_p which have been checked for
5859 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5861 tree dst, dlen, dtype;
5862 tree src, slen, stype;
5865 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5866 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5868 dtype = TREE_TYPE (dst);
5869 if (POINTER_TYPE_P (dtype))
5870 dtype = TREE_TYPE (dtype);
5871 stype = TREE_TYPE (src);
5872 if (POINTER_TYPE_P (stype))
5873 stype = TREE_TYPE (stype);
5875 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5878 /* Determine the lengths of the arrays. */
5879 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5880 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5882 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5883 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5884 dlen, fold_convert (gfc_array_index_type, tmp));
5886 slen = GFC_TYPE_ARRAY_SIZE (stype);
5887 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5889 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5890 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5891 slen, fold_convert (gfc_array_index_type, tmp));
5893 /* Sanity check that they are the same. This should always be
5894 the case, as we should already have checked for conformance. */
5895 if (!tree_int_cst_equal (slen, dlen))
5898 return gfc_build_memcpy_call (dst, src, dlen);
5902 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5903 this can't be done. EXPR1 is the destination/lhs for which
5904 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5907 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5909 unsigned HOST_WIDE_INT nelem;
5915 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5919 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5920 dtype = TREE_TYPE (dst);
5921 if (POINTER_TYPE_P (dtype))
5922 dtype = TREE_TYPE (dtype);
5923 if (!GFC_ARRAY_TYPE_P (dtype))
5926 /* Determine the lengths of the array. */
5927 len = GFC_TYPE_ARRAY_SIZE (dtype);
5928 if (!len || TREE_CODE (len) != INTEGER_CST)
5931 /* Confirm that the constructor is the same size. */
5932 if (compare_tree_int (len, nelem) != 0)
5935 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5936 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5937 fold_convert (gfc_array_index_type, tmp));
5939 stype = gfc_typenode_for_spec (&expr2->ts);
5940 src = gfc_build_constant_array_constructor (expr2, stype);
5942 stype = TREE_TYPE (src);
5943 if (POINTER_TYPE_P (stype))
5944 stype = TREE_TYPE (stype);
5946 return gfc_build_memcpy_call (dst, src, len);
5950 /* Tells whether the expression is to be treated as a variable reference. */
5953 expr_is_variable (gfc_expr *expr)
5957 if (expr->expr_type == EXPR_VARIABLE)
5960 arg = gfc_get_noncopying_intrinsic_argument (expr);
5963 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5964 return expr_is_variable (arg);
5971 /* Is the lhs OK for automatic reallocation? */
5974 is_scalar_reallocatable_lhs (gfc_expr *expr)
5978 /* An allocatable variable with no reference. */
5979 if (expr->symtree->n.sym->attr.allocatable
5983 /* All that can be left are allocatable components. */
5984 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5985 && expr->symtree->n.sym->ts.type != BT_CLASS)
5986 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5989 /* Find an allocatable component ref last. */
5990 for (ref = expr->ref; ref; ref = ref->next)
5991 if (ref->type == REF_COMPONENT
5993 && ref->u.c.component->attr.allocatable)
6000 /* Allocate or reallocate scalar lhs, as necessary. */
6003 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6017 if (!expr1 || expr1->rank)
6020 if (!expr2 || expr2->rank)
6023 /* Since this is a scalar lhs, we can afford to do this. That is,
6024 there is no risk of side effects being repeated. */
6025 gfc_init_se (&lse, NULL);
6026 lse.want_pointer = 1;
6027 gfc_conv_expr (&lse, expr1);
6029 jump_label1 = gfc_build_label_decl (NULL_TREE);
6030 jump_label2 = gfc_build_label_decl (NULL_TREE);
6032 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6033 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6034 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6036 tmp = build3_v (COND_EXPR, cond,
6037 build1_v (GOTO_EXPR, jump_label1),
6038 build_empty_stmt (input_location));
6039 gfc_add_expr_to_block (block, tmp);
6041 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6043 /* Use the rhs string length and the lhs element size. */
6044 size = string_length;
6045 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6046 tmp = TYPE_SIZE_UNIT (tmp);
6047 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6048 TREE_TYPE (tmp), tmp,
6049 fold_convert (TREE_TYPE (tmp), size));
6053 /* Otherwise use the length in bytes of the rhs. */
6054 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6055 size_in_bytes = size;
6058 tmp = build_call_expr_loc (input_location,
6059 built_in_decls[BUILT_IN_MALLOC], 1,
6061 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6062 gfc_add_modify (block, lse.expr, tmp);
6063 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6065 /* Deferred characters need checking for lhs and rhs string
6066 length. Other deferred parameter variables will have to
6068 tmp = build1_v (GOTO_EXPR, jump_label2);
6069 gfc_add_expr_to_block (block, tmp);
6071 tmp = build1_v (LABEL_EXPR, jump_label1);
6072 gfc_add_expr_to_block (block, tmp);
6074 /* For a deferred length character, reallocate if lengths of lhs and
6075 rhs are different. */
6076 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6078 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6079 expr1->ts.u.cl->backend_decl, size);
6080 /* Jump past the realloc if the lengths are the same. */
6081 tmp = build3_v (COND_EXPR, cond,
6082 build1_v (GOTO_EXPR, jump_label2),
6083 build_empty_stmt (input_location));
6084 gfc_add_expr_to_block (block, tmp);
6085 tmp = build_call_expr_loc (input_location,
6086 built_in_decls[BUILT_IN_REALLOC], 2,
6087 fold_convert (pvoid_type_node, lse.expr),
6089 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6090 gfc_add_modify (block, lse.expr, tmp);
6091 tmp = build1_v (LABEL_EXPR, jump_label2);
6092 gfc_add_expr_to_block (block, tmp);
6094 /* Update the lhs character length. */
6095 size = string_length;
6096 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6101 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6102 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6103 init_flag indicates initialization expressions and dealloc that no
6104 deallocate prior assignment is needed (if in doubt, set true). */
6107 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6113 gfc_ss *lss_section;
6120 bool scalar_to_array;
6125 /* Assignment of the form lhs = rhs. */
6126 gfc_start_block (&block);
6128 gfc_init_se (&lse, NULL);
6129 gfc_init_se (&rse, NULL);
6132 lss = gfc_walk_expr (expr1);
6133 if (gfc_is_reallocatable_lhs (expr1)
6134 && !(expr2->expr_type == EXPR_FUNCTION
6135 && expr2->value.function.isym != NULL))
6136 lss->is_alloc_lhs = 1;
6138 if (lss != gfc_ss_terminator)
6140 /* The assignment needs scalarization. */
6143 /* Find a non-scalar SS from the lhs. */
6144 while (lss_section != gfc_ss_terminator
6145 && lss_section->type != GFC_SS_SECTION)
6146 lss_section = lss_section->next;
6148 gcc_assert (lss_section != gfc_ss_terminator);
6150 /* Initialize the scalarizer. */
6151 gfc_init_loopinfo (&loop);
6154 rss = gfc_walk_expr (expr2);
6155 if (rss == gfc_ss_terminator)
6156 /* The rhs is scalar. Add a ss for the expression. */
6157 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6159 /* Associate the SS with the loop. */
6160 gfc_add_ss_to_loop (&loop, lss);
6161 gfc_add_ss_to_loop (&loop, rss);
6163 /* Calculate the bounds of the scalarization. */
6164 gfc_conv_ss_startstride (&loop);
6165 /* Enable loop reversal. */
6166 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6167 loop.reverse[n] = GFC_ENABLE_REVERSE;
6168 /* Resolve any data dependencies in the statement. */
6169 gfc_conv_resolve_dependencies (&loop, lss, rss);
6170 /* Setup the scalarizing loops. */
6171 gfc_conv_loop_setup (&loop, &expr2->where);
6173 /* Setup the gfc_se structures. */
6174 gfc_copy_loopinfo_to_se (&lse, &loop);
6175 gfc_copy_loopinfo_to_se (&rse, &loop);
6178 gfc_mark_ss_chain_used (rss, 1);
6179 if (loop.temp_ss == NULL)
6182 gfc_mark_ss_chain_used (lss, 1);
6186 lse.ss = loop.temp_ss;
6187 gfc_mark_ss_chain_used (lss, 3);
6188 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6191 /* Allow the scalarizer to workshare array assignments. */
6192 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6193 ompws_flags |= OMPWS_SCALARIZER_WS;
6195 /* Start the scalarized loop body. */
6196 gfc_start_scalarized_body (&loop, &body);
6199 gfc_init_block (&body);
6201 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6203 /* Translate the expression. */
6204 gfc_conv_expr (&rse, expr2);
6206 /* Stabilize a string length for temporaries. */
6207 if (expr2->ts.type == BT_CHARACTER)
6208 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6210 string_length = NULL_TREE;
6214 gfc_conv_tmp_array_ref (&lse);
6215 if (expr2->ts.type == BT_CHARACTER)
6216 lse.string_length = string_length;
6219 gfc_conv_expr (&lse, expr1);
6221 /* Assignments of scalar derived types with allocatable components
6222 to arrays must be done with a deep copy and the rhs temporary
6223 must have its components deallocated afterwards. */
6224 scalar_to_array = (expr2->ts.type == BT_DERIVED
6225 && expr2->ts.u.derived->attr.alloc_comp
6226 && !expr_is_variable (expr2)
6227 && !gfc_is_constant_expr (expr2)
6228 && expr1->rank && !expr2->rank);
6229 if (scalar_to_array && dealloc)
6231 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6232 gfc_add_expr_to_block (&loop.post, tmp);
6235 /* For a deferred character length function, the function call must
6236 happen before the (re)allocation of the lhs, otherwise the character
6237 length of the result is not known. */
6238 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6239 || (expr2->expr_type == EXPR_COMPCALL)
6240 || (expr2->expr_type == EXPR_PPC))
6241 && expr2->ts.deferred);
6242 if (gfc_option.flag_realloc_lhs
6243 && expr2->ts.type == BT_CHARACTER
6244 && (def_clen_func || expr2->expr_type == EXPR_OP)
6245 && expr1->ts.deferred)
6246 gfc_add_block_to_block (&block, &rse.pre);
6248 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6249 l_is_temp || init_flag,
6250 expr_is_variable (expr2) || scalar_to_array
6251 || expr2->expr_type == EXPR_ARRAY, dealloc);
6252 gfc_add_expr_to_block (&body, tmp);
6254 if (lss == gfc_ss_terminator)
6256 /* F2003: Add the code for reallocation on assignment. */
6257 if (gfc_option.flag_realloc_lhs
6258 && is_scalar_reallocatable_lhs (expr1))
6259 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6262 /* Use the scalar assignment as is. */
6263 gfc_add_block_to_block (&block, &body);
6267 gcc_assert (lse.ss == gfc_ss_terminator
6268 && rse.ss == gfc_ss_terminator);
6272 gfc_trans_scalarized_loop_boundary (&loop, &body);
6274 /* We need to copy the temporary to the actual lhs. */
6275 gfc_init_se (&lse, NULL);
6276 gfc_init_se (&rse, NULL);
6277 gfc_copy_loopinfo_to_se (&lse, &loop);
6278 gfc_copy_loopinfo_to_se (&rse, &loop);
6280 rse.ss = loop.temp_ss;
6283 gfc_conv_tmp_array_ref (&rse);
6284 gfc_conv_expr (&lse, expr1);
6286 gcc_assert (lse.ss == gfc_ss_terminator
6287 && rse.ss == gfc_ss_terminator);
6289 if (expr2->ts.type == BT_CHARACTER)
6290 rse.string_length = string_length;
6292 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6293 false, false, dealloc);
6294 gfc_add_expr_to_block (&body, tmp);
6297 /* F2003: Allocate or reallocate lhs of allocatable array. */
6298 if (gfc_option.flag_realloc_lhs
6299 && gfc_is_reallocatable_lhs (expr1)
6300 && !gfc_expr_attr (expr1).codimension
6301 && !gfc_is_coindexed (expr1))
6303 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6304 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6305 if (tmp != NULL_TREE)
6306 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6309 /* Generate the copying loops. */
6310 gfc_trans_scalarizing_loops (&loop, &body);
6312 /* Wrap the whole thing up. */
6313 gfc_add_block_to_block (&block, &loop.pre);
6314 gfc_add_block_to_block (&block, &loop.post);
6316 gfc_cleanup_loop (&loop);
6319 return gfc_finish_block (&block);
6323 /* Check whether EXPR is a copyable array. */
6326 copyable_array_p (gfc_expr * expr)
6328 if (expr->expr_type != EXPR_VARIABLE)
6331 /* First check it's an array. */
6332 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6335 if (!gfc_full_array_ref_p (expr->ref, NULL))
6338 /* Next check that it's of a simple enough type. */
6339 switch (expr->ts.type)
6351 return !expr->ts.u.derived->attr.alloc_comp;
6360 /* Translate an assignment. */
6363 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6368 /* Special case a single function returning an array. */
6369 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6371 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6376 /* Special case assigning an array to zero. */
6377 if (copyable_array_p (expr1)
6378 && is_zero_initializer_p (expr2))
6380 tmp = gfc_trans_zero_assign (expr1);
6385 /* Special case copying one array to another. */
6386 if (copyable_array_p (expr1)
6387 && copyable_array_p (expr2)
6388 && gfc_compare_types (&expr1->ts, &expr2->ts)
6389 && !gfc_check_dependency (expr1, expr2, 0))
6391 tmp = gfc_trans_array_copy (expr1, expr2);
6396 /* Special case initializing an array from a constant array constructor. */
6397 if (copyable_array_p (expr1)
6398 && expr2->expr_type == EXPR_ARRAY
6399 && gfc_compare_types (&expr1->ts, &expr2->ts))
6401 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6406 /* Fallback to the scalarizer to generate explicit loops. */
6407 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6411 gfc_trans_init_assign (gfc_code * code)
6413 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6417 gfc_trans_assign (gfc_code * code)
6419 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6423 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6424 A MEMCPY is needed to copy the full data from the default initializer
6425 of the dynamic type. */
6428 gfc_trans_class_init_assign (gfc_code *code)
6432 gfc_se dst,src,memsz;
6433 gfc_expr *lhs,*rhs,*sz;
6435 gfc_start_block (&block);
6437 lhs = gfc_copy_expr (code->expr1);
6438 gfc_add_data_component (lhs);
6440 rhs = gfc_copy_expr (code->expr1);
6441 gfc_add_vptr_component (rhs);
6443 /* Make sure that the component backend_decls have been built, which
6444 will not have happened if the derived types concerned have not
6446 gfc_get_derived_type (rhs->ts.u.derived);
6447 gfc_add_def_init_component (rhs);
6449 sz = gfc_copy_expr (code->expr1);
6450 gfc_add_vptr_component (sz);
6451 gfc_add_size_component (sz);
6453 gfc_init_se (&dst, NULL);
6454 gfc_init_se (&src, NULL);
6455 gfc_init_se (&memsz, NULL);
6456 gfc_conv_expr (&dst, lhs);
6457 gfc_conv_expr (&src, rhs);
6458 gfc_conv_expr (&memsz, sz);
6459 gfc_add_block_to_block (&block, &src.pre);
6460 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6461 gfc_add_expr_to_block (&block, tmp);
6463 return gfc_finish_block (&block);
6467 /* Translate an assignment to a CLASS object
6468 (pointer or ordinary assignment). */
6471 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6478 gfc_start_block (&block);
6480 if (expr2->ts.type != BT_CLASS)
6482 /* Insert an additional assignment which sets the '_vptr' field. */
6483 gfc_symbol *vtab = NULL;
6486 lhs = gfc_copy_expr (expr1);
6487 gfc_add_vptr_component (lhs);
6489 if (expr2->ts.type == BT_DERIVED)
6490 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6491 else if (expr2->expr_type == EXPR_NULL)
6492 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6495 rhs = gfc_get_expr ();
6496 rhs->expr_type = EXPR_VARIABLE;
6497 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6501 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6502 gfc_add_expr_to_block (&block, tmp);
6504 gfc_free_expr (lhs);
6505 gfc_free_expr (rhs);
6508 /* Do the actual CLASS assignment. */
6509 if (expr2->ts.type == BT_CLASS)
6512 gfc_add_data_component (expr1);
6514 if (op == EXEC_ASSIGN)
6515 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6516 else if (op == EXEC_POINTER_ASSIGN)
6517 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6521 gfc_add_expr_to_block (&block, tmp);
6523 return gfc_finish_block (&block);