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 = builtin_decl_explicit (BUILT_IN_POWIF);
1131 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1135 fndecl = builtin_decl_explicit (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 = builtin_decl_explicit (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;
3362 /* If the argument is passed by value, we need to strip the
3364 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3365 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3367 cond = fold_build2_loc (input_location, EQ_EXPR,
3368 boolean_type_node, tmp,
3369 fold_convert (TREE_TYPE (tmp),
3370 null_pointer_node));
3373 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3379 /* Deferred length dummies pass the character length by reference
3380 so that the value can be returned. */
3381 if (parmse.string_length && fsym && fsym->ts.deferred)
3383 tmp = parmse.string_length;
3384 if (TREE_CODE (tmp) != VAR_DECL)
3385 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3386 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3389 /* Character strings are passed as two parameters, a length and a
3390 pointer - except for Bind(c) which only passes the pointer. */
3391 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3392 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3394 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3395 pass the token and the offset as additional arguments. */
3396 if (fsym && fsym->attr.codimension
3397 && gfc_option.coarray == GFC_FCOARRAY_LIB
3398 && !fsym->attr.allocatable
3401 /* Token and offset. */
3402 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
3403 VEC_safe_push (tree, gc, stringargs,
3404 build_int_cst (gfc_array_index_type, 0));
3405 gcc_assert (fsym->attr.optional);
3407 else if (fsym && fsym->attr.codimension
3408 && !fsym->attr.allocatable
3409 && gfc_option.coarray == GFC_FCOARRAY_LIB)
3411 tree caf_decl, caf_type;
3414 caf_decl = get_tree_for_caf_expr (e);
3415 caf_type = TREE_TYPE (caf_decl);
3417 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3418 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3419 tmp = gfc_conv_descriptor_token (caf_decl);
3420 else if (DECL_LANG_SPECIFIC (caf_decl)
3421 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
3422 tmp = GFC_DECL_TOKEN (caf_decl);
3425 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
3426 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
3427 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
3430 VEC_safe_push (tree, gc, stringargs, tmp);
3432 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3433 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3434 offset = build_int_cst (gfc_array_index_type, 0);
3435 else if (DECL_LANG_SPECIFIC (caf_decl)
3436 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
3437 offset = GFC_DECL_CAF_OFFSET (caf_decl);
3438 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3439 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
3441 offset = build_int_cst (gfc_array_index_type, 0);
3443 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
3444 tmp = gfc_conv_descriptor_data_get (caf_decl);
3447 gcc_assert (POINTER_TYPE_P (caf_type));
3451 if (fsym->as->type == AS_ASSUMED_SHAPE)
3453 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3454 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3455 (TREE_TYPE (parmse.expr))));
3456 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
3457 tmp2 = gfc_conv_descriptor_data_get (tmp2);
3459 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3460 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
3463 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3467 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3468 gfc_array_index_type,
3469 fold_convert (gfc_array_index_type, tmp2),
3470 fold_convert (gfc_array_index_type, tmp));
3471 offset = fold_build2_loc (input_location, PLUS_EXPR,
3472 gfc_array_index_type, offset, tmp);
3474 VEC_safe_push (tree, gc, stringargs, offset);
3477 VEC_safe_push (tree, gc, arglist, parmse.expr);
3479 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3486 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3487 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3488 else if (ts.type == BT_CHARACTER)
3490 if (ts.u.cl->length == NULL)
3492 /* Assumed character length results are not allowed by 5.1.1.5 of the
3493 standard and are trapped in resolve.c; except in the case of SPREAD
3494 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3495 we take the character length of the first argument for the result.
3496 For dummies, we have to look through the formal argument list for
3497 this function and use the character length found there.*/
3498 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3499 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3500 else if (!sym->attr.dummy)
3501 cl.backend_decl = VEC_index (tree, stringargs, 0);
3504 formal = sym->ns->proc_name->formal;
3505 for (; formal; formal = formal->next)
3506 if (strcmp (formal->sym->name, sym->name) == 0)
3507 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3514 /* Calculate the length of the returned string. */
3515 gfc_init_se (&parmse, NULL);
3516 if (need_interface_mapping)
3517 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3519 gfc_conv_expr (&parmse, ts.u.cl->length);
3520 gfc_add_block_to_block (&se->pre, &parmse.pre);
3521 gfc_add_block_to_block (&se->post, &parmse.post);
3523 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3524 tmp = fold_build2_loc (input_location, MAX_EXPR,
3525 gfc_charlen_type_node, tmp,
3526 build_int_cst (gfc_charlen_type_node, 0));
3527 cl.backend_decl = tmp;
3530 /* Set up a charlen structure for it. */
3535 len = cl.backend_decl;
3538 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3539 || (!comp && gfc_return_by_reference (sym));
3542 if (se->direct_byref)
3544 /* Sometimes, too much indirection can be applied; e.g. for
3545 function_result = array_valued_recursive_function. */
3546 if (TREE_TYPE (TREE_TYPE (se->expr))
3547 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3548 && GFC_DESCRIPTOR_TYPE_P
3549 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3550 se->expr = build_fold_indirect_ref_loc (input_location,
3553 /* If the lhs of an assignment x = f(..) is allocatable and
3554 f2003 is allowed, we must do the automatic reallocation.
3555 TODO - deal with intrinsics, without using a temporary. */
3556 if (gfc_option.flag_realloc_lhs
3557 && se->ss && se->ss->loop_chain
3558 && se->ss->loop_chain->is_alloc_lhs
3559 && !expr->value.function.isym
3560 && sym->result->as != NULL)
3562 /* Evaluate the bounds of the result, if known. */
3563 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3566 /* Perform the automatic reallocation. */
3567 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3569 gfc_add_expr_to_block (&se->pre, tmp);
3571 /* Pass the temporary as the first argument. */
3572 result = info->descriptor;
3575 result = build_fold_indirect_ref_loc (input_location,
3577 VEC_safe_push (tree, gc, retargs, se->expr);
3579 else if (comp && comp->attr.dimension)
3581 gcc_assert (se->loop && info);
3583 /* Set the type of the array. */
3584 tmp = gfc_typenode_for_spec (&comp->ts);
3585 gcc_assert (info->dimen == se->loop->dimen);
3587 /* Evaluate the bounds of the result, if known. */
3588 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3590 /* If the lhs of an assignment x = f(..) is allocatable and
3591 f2003 is allowed, we must not generate the function call
3592 here but should just send back the results of the mapping.
3593 This is signalled by the function ss being flagged. */
3594 if (gfc_option.flag_realloc_lhs
3595 && se->ss && se->ss->is_alloc_lhs)
3597 gfc_free_interface_mapping (&mapping);
3598 return has_alternate_specifier;
3601 /* Create a temporary to store the result. In case the function
3602 returns a pointer, the temporary will be a shallow copy and
3603 mustn't be deallocated. */
3604 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3605 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3606 NULL_TREE, false, !comp->attr.pointer,
3607 callee_alloc, &se->ss->expr->where);
3609 /* Pass the temporary as the first argument. */
3610 result = info->descriptor;
3611 tmp = gfc_build_addr_expr (NULL_TREE, result);
3612 VEC_safe_push (tree, gc, retargs, tmp);
3614 else if (!comp && sym->result->attr.dimension)
3616 gcc_assert (se->loop && info);
3618 /* Set the type of the array. */
3619 tmp = gfc_typenode_for_spec (&ts);
3620 gcc_assert (info->dimen == se->loop->dimen);
3622 /* Evaluate the bounds of the result, if known. */
3623 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3625 /* If the lhs of an assignment x = f(..) is allocatable and
3626 f2003 is allowed, we must not generate the function call
3627 here but should just send back the results of the mapping.
3628 This is signalled by the function ss being flagged. */
3629 if (gfc_option.flag_realloc_lhs
3630 && se->ss && se->ss->is_alloc_lhs)
3632 gfc_free_interface_mapping (&mapping);
3633 return has_alternate_specifier;
3636 /* Create a temporary to store the result. In case the function
3637 returns a pointer, the temporary will be a shallow copy and
3638 mustn't be deallocated. */
3639 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3640 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3641 NULL_TREE, false, !sym->attr.pointer,
3642 callee_alloc, &se->ss->expr->where);
3644 /* Pass the temporary as the first argument. */
3645 result = info->descriptor;
3646 tmp = gfc_build_addr_expr (NULL_TREE, result);
3647 VEC_safe_push (tree, gc, retargs, tmp);
3649 else if (ts.type == BT_CHARACTER)
3651 /* Pass the string length. */
3652 type = gfc_get_character_type (ts.kind, ts.u.cl);
3653 type = build_pointer_type (type);
3655 /* Return an address to a char[0:len-1]* temporary for
3656 character pointers. */
3657 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3658 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3660 var = gfc_create_var (type, "pstr");
3662 if ((!comp && sym->attr.allocatable)
3663 || (comp && comp->attr.allocatable))
3664 gfc_add_modify (&se->pre, var,
3665 fold_convert (TREE_TYPE (var),
3666 null_pointer_node));
3668 /* Provide an address expression for the function arguments. */
3669 var = gfc_build_addr_expr (NULL_TREE, var);
3672 var = gfc_conv_string_tmp (se, type, len);
3674 VEC_safe_push (tree, gc, retargs, var);
3678 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3680 type = gfc_get_complex_type (ts.kind);
3681 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3682 VEC_safe_push (tree, gc, retargs, var);
3685 if (ts.type == BT_CHARACTER && ts.deferred
3686 && (sym->attr.allocatable || sym->attr.pointer))
3689 if (TREE_CODE (tmp) != VAR_DECL)
3690 tmp = gfc_evaluate_now (len, &se->pre);
3691 len = gfc_build_addr_expr (NULL_TREE, tmp);
3694 /* Add the string length to the argument list. */
3695 if (ts.type == BT_CHARACTER)
3696 VEC_safe_push (tree, gc, retargs, len);
3698 gfc_free_interface_mapping (&mapping);
3700 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3701 arglen = (VEC_length (tree, arglist)
3702 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3703 VEC_reserve_exact (tree, gc, retargs, arglen);
3705 /* Add the return arguments. */
3706 VEC_splice (tree, retargs, arglist);
3708 /* Add the hidden string length parameters to the arguments. */
3709 VEC_splice (tree, retargs, stringargs);
3711 /* We may want to append extra arguments here. This is used e.g. for
3712 calls to libgfortran_matmul_??, which need extra information. */
3713 if (!VEC_empty (tree, append_args))
3714 VEC_splice (tree, retargs, append_args);
3717 /* Generate the actual call. */
3718 conv_function_val (se, sym, expr);
3720 /* If there are alternate return labels, function type should be
3721 integer. Can't modify the type in place though, since it can be shared
3722 with other functions. For dummy arguments, the typing is done to
3723 this result, even if it has to be repeated for each call. */
3724 if (has_alternate_specifier
3725 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3727 if (!sym->attr.dummy)
3729 TREE_TYPE (sym->backend_decl)
3730 = build_function_type (integer_type_node,
3731 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3732 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3735 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3738 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3739 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3741 /* If we have a pointer function, but we don't want a pointer, e.g.
3744 where f is pointer valued, we have to dereference the result. */
3745 if (!se->want_pointer && !byref
3746 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3747 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3748 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3750 /* f2c calling conventions require a scalar default real function to
3751 return a double precision result. Convert this back to default
3752 real. We only care about the cases that can happen in Fortran 77.
3754 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3755 && sym->ts.kind == gfc_default_real_kind
3756 && !sym->attr.always_explicit)
3757 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3759 /* A pure function may still have side-effects - it may modify its
3761 TREE_SIDE_EFFECTS (se->expr) = 1;
3763 if (!sym->attr.pure)
3764 TREE_SIDE_EFFECTS (se->expr) = 1;
3769 /* Add the function call to the pre chain. There is no expression. */
3770 gfc_add_expr_to_block (&se->pre, se->expr);
3771 se->expr = NULL_TREE;
3773 if (!se->direct_byref)
3775 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3777 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3779 /* Check the data pointer hasn't been modified. This would
3780 happen in a function returning a pointer. */
3781 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3782 tmp = fold_build2_loc (input_location, NE_EXPR,
3785 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3788 se->expr = info->descriptor;
3789 /* Bundle in the string length. */
3790 se->string_length = len;
3792 else if (ts.type == BT_CHARACTER)
3794 /* Dereference for character pointer results. */
3795 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3796 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3797 se->expr = build_fold_indirect_ref_loc (input_location, var);
3802 se->string_length = len;
3803 else if (sym->attr.allocatable || sym->attr.pointer)
3804 se->string_length = cl.backend_decl;
3808 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3809 se->expr = build_fold_indirect_ref_loc (input_location, var);
3814 /* Follow the function call with the argument post block. */
3817 gfc_add_block_to_block (&se->pre, &post);
3819 /* Transformational functions of derived types with allocatable
3820 components must have the result allocatable components copied. */
3821 arg = expr->value.function.actual;
3822 if (result && arg && expr->rank
3823 && expr->value.function.isym
3824 && expr->value.function.isym->transformational
3825 && arg->expr->ts.type == BT_DERIVED
3826 && arg->expr->ts.u.derived->attr.alloc_comp)
3829 /* Copy the allocatable components. We have to use a
3830 temporary here to prevent source allocatable components
3831 from being corrupted. */
3832 tmp2 = gfc_evaluate_now (result, &se->pre);
3833 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3834 result, tmp2, expr->rank);
3835 gfc_add_expr_to_block (&se->pre, tmp);
3836 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3838 gfc_add_expr_to_block (&se->pre, tmp);
3840 /* Finally free the temporary's data field. */
3841 tmp = gfc_conv_descriptor_data_get (tmp2);
3842 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3843 gfc_add_expr_to_block (&se->pre, tmp);
3847 gfc_add_block_to_block (&se->post, &post);
3849 return has_alternate_specifier;
3853 /* Fill a character string with spaces. */
3856 fill_with_spaces (tree start, tree type, tree size)
3858 stmtblock_t block, loop;
3859 tree i, el, exit_label, cond, tmp;
3861 /* For a simple char type, we can call memset(). */
3862 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3863 return build_call_expr_loc (input_location,
3864 builtin_decl_explicit (BUILT_IN_MEMSET),
3866 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3867 lang_hooks.to_target_charset (' ')),
3870 /* Otherwise, we use a loop:
3871 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3875 /* Initialize variables. */
3876 gfc_init_block (&block);
3877 i = gfc_create_var (sizetype, "i");
3878 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3879 el = gfc_create_var (build_pointer_type (type), "el");
3880 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3881 exit_label = gfc_build_label_decl (NULL_TREE);
3882 TREE_USED (exit_label) = 1;
3886 gfc_init_block (&loop);
3888 /* Exit condition. */
3889 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3890 build_zero_cst (sizetype));
3891 tmp = build1_v (GOTO_EXPR, exit_label);
3892 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3893 build_empty_stmt (input_location));
3894 gfc_add_expr_to_block (&loop, tmp);
3897 gfc_add_modify (&loop,
3898 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3899 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3901 /* Increment loop variables. */
3902 gfc_add_modify (&loop, i,
3903 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3904 TYPE_SIZE_UNIT (type)));
3905 gfc_add_modify (&loop, el,
3906 fold_build_pointer_plus_loc (input_location,
3907 el, TYPE_SIZE_UNIT (type)));
3909 /* Making the loop... actually loop! */
3910 tmp = gfc_finish_block (&loop);
3911 tmp = build1_v (LOOP_EXPR, tmp);
3912 gfc_add_expr_to_block (&block, tmp);
3914 /* The exit label. */
3915 tmp = build1_v (LABEL_EXPR, exit_label);
3916 gfc_add_expr_to_block (&block, tmp);
3919 return gfc_finish_block (&block);
3923 /* Generate code to copy a string. */
3926 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3927 int dkind, tree slength, tree src, int skind)
3929 tree tmp, dlen, slen;
3938 stmtblock_t tempblock;
3940 gcc_assert (dkind == skind);
3942 if (slength != NULL_TREE)
3944 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3945 ssc = gfc_string_to_single_character (slen, src, skind);
3949 slen = build_int_cst (size_type_node, 1);
3953 if (dlength != NULL_TREE)
3955 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3956 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3960 dlen = build_int_cst (size_type_node, 1);
3964 /* Assign directly if the types are compatible. */
3965 if (dsc != NULL_TREE && ssc != NULL_TREE
3966 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3968 gfc_add_modify (block, dsc, ssc);
3972 /* Do nothing if the destination length is zero. */
3973 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3974 build_int_cst (size_type_node, 0));
3976 /* The following code was previously in _gfortran_copy_string:
3978 // The two strings may overlap so we use memmove.
3980 copy_string (GFC_INTEGER_4 destlen, char * dest,
3981 GFC_INTEGER_4 srclen, const char * src)
3983 if (srclen >= destlen)
3985 // This will truncate if too long.
3986 memmove (dest, src, destlen);
3990 memmove (dest, src, srclen);
3992 memset (&dest[srclen], ' ', destlen - srclen);
3996 We're now doing it here for better optimization, but the logic
3999 /* For non-default character kinds, we have to multiply the string
4000 length by the base type size. */
4001 chartype = gfc_get_char_type (dkind);
4002 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4003 fold_convert (size_type_node, slen),
4004 fold_convert (size_type_node,
4005 TYPE_SIZE_UNIT (chartype)));
4006 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4007 fold_convert (size_type_node, dlen),
4008 fold_convert (size_type_node,
4009 TYPE_SIZE_UNIT (chartype)));
4011 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4012 dest = fold_convert (pvoid_type_node, dest);
4014 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4016 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4017 src = fold_convert (pvoid_type_node, src);
4019 src = gfc_build_addr_expr (pvoid_type_node, src);
4021 /* Truncate string if source is too long. */
4022 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4024 tmp2 = build_call_expr_loc (input_location,
4025 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4026 3, dest, src, dlen);
4028 /* Else copy and pad with spaces. */
4029 tmp3 = build_call_expr_loc (input_location,
4030 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4031 3, dest, src, slen);
4033 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4034 tmp4 = fill_with_spaces (tmp4, chartype,
4035 fold_build2_loc (input_location, MINUS_EXPR,
4036 TREE_TYPE(dlen), dlen, slen));
4038 gfc_init_block (&tempblock);
4039 gfc_add_expr_to_block (&tempblock, tmp3);
4040 gfc_add_expr_to_block (&tempblock, tmp4);
4041 tmp3 = gfc_finish_block (&tempblock);
4043 /* The whole copy_string function is there. */
4044 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4046 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4047 build_empty_stmt (input_location));
4048 gfc_add_expr_to_block (block, tmp);
4052 /* Translate a statement function.
4053 The value of a statement function reference is obtained by evaluating the
4054 expression using the values of the actual arguments for the values of the
4055 corresponding dummy arguments. */
4058 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4062 gfc_formal_arglist *fargs;
4063 gfc_actual_arglist *args;
4066 gfc_saved_var *saved_vars;
4072 sym = expr->symtree->n.sym;
4073 args = expr->value.function.actual;
4074 gfc_init_se (&lse, NULL);
4075 gfc_init_se (&rse, NULL);
4078 for (fargs = sym->formal; fargs; fargs = fargs->next)
4080 saved_vars = XCNEWVEC (gfc_saved_var, n);
4081 temp_vars = XCNEWVEC (tree, n);
4083 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4085 /* Each dummy shall be specified, explicitly or implicitly, to be
4087 gcc_assert (fargs->sym->attr.dimension == 0);
4090 if (fsym->ts.type == BT_CHARACTER)
4092 /* Copy string arguments. */
4095 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4096 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4098 /* Create a temporary to hold the value. */
4099 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4100 fsym->ts.u.cl->backend_decl
4101 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4103 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4104 temp_vars[n] = gfc_create_var (type, fsym->name);
4106 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4108 gfc_conv_expr (&rse, args->expr);
4109 gfc_conv_string_parameter (&rse);
4110 gfc_add_block_to_block (&se->pre, &lse.pre);
4111 gfc_add_block_to_block (&se->pre, &rse.pre);
4113 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4114 rse.string_length, rse.expr, fsym->ts.kind);
4115 gfc_add_block_to_block (&se->pre, &lse.post);
4116 gfc_add_block_to_block (&se->pre, &rse.post);
4120 /* For everything else, just evaluate the expression. */
4122 /* Create a temporary to hold the value. */
4123 type = gfc_typenode_for_spec (&fsym->ts);
4124 temp_vars[n] = gfc_create_var (type, fsym->name);
4126 gfc_conv_expr (&lse, args->expr);
4128 gfc_add_block_to_block (&se->pre, &lse.pre);
4129 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4130 gfc_add_block_to_block (&se->pre, &lse.post);
4136 /* Use the temporary variables in place of the real ones. */
4137 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4138 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4140 gfc_conv_expr (se, sym->value);
4142 if (sym->ts.type == BT_CHARACTER)
4144 gfc_conv_const_charlen (sym->ts.u.cl);
4146 /* Force the expression to the correct length. */
4147 if (!INTEGER_CST_P (se->string_length)
4148 || tree_int_cst_lt (se->string_length,
4149 sym->ts.u.cl->backend_decl))
4151 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4152 tmp = gfc_create_var (type, sym->name);
4153 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4154 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4155 sym->ts.kind, se->string_length, se->expr,
4159 se->string_length = sym->ts.u.cl->backend_decl;
4162 /* Restore the original variables. */
4163 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4164 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4169 /* Translate a function expression. */
4172 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4176 if (expr->value.function.isym)
4178 gfc_conv_intrinsic_function (se, expr);
4182 /* We distinguish statement functions from general functions to improve
4183 runtime performance. */
4184 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4186 gfc_conv_statement_function (se, expr);
4190 /* expr.value.function.esym is the resolved (specific) function symbol for
4191 most functions. However this isn't set for dummy procedures. */
4192 sym = expr->value.function.esym;
4194 sym = expr->symtree->n.sym;
4196 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4200 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4203 is_zero_initializer_p (gfc_expr * expr)
4205 if (expr->expr_type != EXPR_CONSTANT)
4208 /* We ignore constants with prescribed memory representations for now. */
4209 if (expr->representation.string)
4212 switch (expr->ts.type)
4215 return mpz_cmp_si (expr->value.integer, 0) == 0;
4218 return mpfr_zero_p (expr->value.real)
4219 && MPFR_SIGN (expr->value.real) >= 0;
4222 return expr->value.logical == 0;
4225 return mpfr_zero_p (mpc_realref (expr->value.complex))
4226 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4227 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4228 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4238 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4240 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4241 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4243 gfc_conv_tmp_array_ref (se);
4247 /* Build a static initializer. EXPR is the expression for the initial value.
4248 The other parameters describe the variable of the component being
4249 initialized. EXPR may be null. */
4252 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4253 bool array, bool pointer, bool procptr)
4257 if (!(expr || pointer || procptr))
4260 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4261 (these are the only two iso_c_binding derived types that can be
4262 used as initialization expressions). If so, we need to modify
4263 the 'expr' to be that for a (void *). */
4264 if (expr != NULL && expr->ts.type == BT_DERIVED
4265 && expr->ts.is_iso_c && expr->ts.u.derived)
4267 gfc_symbol *derived = expr->ts.u.derived;
4269 /* The derived symbol has already been converted to a (void *). Use
4271 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4272 expr->ts.f90_type = derived->ts.f90_type;
4274 gfc_init_se (&se, NULL);
4275 gfc_conv_constant (&se, expr);
4276 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4280 if (array && !procptr)
4283 /* Arrays need special handling. */
4285 ctor = gfc_build_null_descriptor (type);
4286 /* Special case assigning an array to zero. */
4287 else if (is_zero_initializer_p (expr))
4288 ctor = build_constructor (type, NULL);
4290 ctor = gfc_conv_array_initializer (type, expr);
4291 TREE_STATIC (ctor) = 1;
4294 else if (pointer || procptr)
4296 if (!expr || expr->expr_type == EXPR_NULL)
4297 return fold_convert (type, null_pointer_node);
4300 gfc_init_se (&se, NULL);
4301 se.want_pointer = 1;
4302 gfc_conv_expr (&se, expr);
4303 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4313 gfc_init_se (&se, NULL);
4314 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4315 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4317 gfc_conv_structure (&se, expr, 1);
4318 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4319 TREE_STATIC (se.expr) = 1;
4324 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4325 TREE_STATIC (ctor) = 1;
4330 gfc_init_se (&se, NULL);
4331 gfc_conv_constant (&se, expr);
4332 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4339 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4351 gfc_start_block (&block);
4353 /* Initialize the scalarizer. */
4354 gfc_init_loopinfo (&loop);
4356 gfc_init_se (&lse, NULL);
4357 gfc_init_se (&rse, NULL);
4360 rss = gfc_walk_expr (expr);
4361 if (rss == gfc_ss_terminator)
4362 /* The rhs is scalar. Add a ss for the expression. */
4363 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4365 /* Create a SS for the destination. */
4366 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4368 lss->shape = gfc_get_shape (cm->as->rank);
4369 lss->data.info.descriptor = dest;
4370 lss->data.info.data = gfc_conv_array_data (dest);
4371 lss->data.info.offset = gfc_conv_array_offset (dest);
4372 for (n = 0; n < cm->as->rank; n++)
4374 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4375 lss->data.info.stride[n] = gfc_index_one_node;
4377 mpz_init (lss->shape[n]);
4378 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4379 cm->as->lower[n]->value.integer);
4380 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4383 /* Associate the SS with the loop. */
4384 gfc_add_ss_to_loop (&loop, lss);
4385 gfc_add_ss_to_loop (&loop, rss);
4387 /* Calculate the bounds of the scalarization. */
4388 gfc_conv_ss_startstride (&loop);
4390 /* Setup the scalarizing loops. */
4391 gfc_conv_loop_setup (&loop, &expr->where);
4393 /* Setup the gfc_se structures. */
4394 gfc_copy_loopinfo_to_se (&lse, &loop);
4395 gfc_copy_loopinfo_to_se (&rse, &loop);
4398 gfc_mark_ss_chain_used (rss, 1);
4400 gfc_mark_ss_chain_used (lss, 1);
4402 /* Start the scalarized loop body. */
4403 gfc_start_scalarized_body (&loop, &body);
4405 gfc_conv_tmp_array_ref (&lse);
4406 if (cm->ts.type == BT_CHARACTER)
4407 lse.string_length = cm->ts.u.cl->backend_decl;
4409 gfc_conv_expr (&rse, expr);
4411 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4412 gfc_add_expr_to_block (&body, tmp);
4414 gcc_assert (rse.ss == gfc_ss_terminator);
4416 /* Generate the copying loops. */
4417 gfc_trans_scalarizing_loops (&loop, &body);
4419 /* Wrap the whole thing up. */
4420 gfc_add_block_to_block (&block, &loop.pre);
4421 gfc_add_block_to_block (&block, &loop.post);
4423 gcc_assert (lss->shape != NULL);
4424 gfc_free_shape (&lss->shape, cm->as->rank);
4425 gfc_cleanup_loop (&loop);
4427 return gfc_finish_block (&block);
4432 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4443 gfc_expr *arg = NULL;
4445 gfc_start_block (&block);
4446 gfc_init_se (&se, NULL);
4448 /* Get the descriptor for the expressions. */
4449 rss = gfc_walk_expr (expr);
4450 se.want_pointer = 0;
4451 gfc_conv_expr_descriptor (&se, expr, rss);
4452 gfc_add_block_to_block (&block, &se.pre);
4453 gfc_add_modify (&block, dest, se.expr);
4455 /* Deal with arrays of derived types with allocatable components. */
4456 if (cm->ts.type == BT_DERIVED
4457 && cm->ts.u.derived->attr.alloc_comp)
4458 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4462 tmp = gfc_duplicate_allocatable (dest, se.expr,
4463 TREE_TYPE(cm->backend_decl),
4466 gfc_add_expr_to_block (&block, tmp);
4467 gfc_add_block_to_block (&block, &se.post);
4469 if (expr->expr_type != EXPR_VARIABLE)
4470 gfc_conv_descriptor_data_set (&block, se.expr,
4473 /* We need to know if the argument of a conversion function is a
4474 variable, so that the correct lower bound can be used. */
4475 if (expr->expr_type == EXPR_FUNCTION
4476 && expr->value.function.isym
4477 && expr->value.function.isym->conversion
4478 && expr->value.function.actual->expr
4479 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4480 arg = expr->value.function.actual->expr;
4482 /* Obtain the array spec of full array references. */
4484 as = gfc_get_full_arrayspec_from_expr (arg);
4486 as = gfc_get_full_arrayspec_from_expr (expr);
4488 /* Shift the lbound and ubound of temporaries to being unity,
4489 rather than zero, based. Always calculate the offset. */
4490 offset = gfc_conv_descriptor_offset_get (dest);
4491 gfc_add_modify (&block, offset, gfc_index_zero_node);
4492 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4494 for (n = 0; n < expr->rank; n++)
4499 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4500 TODO It looks as if gfc_conv_expr_descriptor should return
4501 the correct bounds and that the following should not be
4502 necessary. This would simplify gfc_conv_intrinsic_bound
4504 if (as && as->lower[n])
4507 gfc_init_se (&lbse, NULL);
4508 gfc_conv_expr (&lbse, as->lower[n]);
4509 gfc_add_block_to_block (&block, &lbse.pre);
4510 lbound = gfc_evaluate_now (lbse.expr, &block);
4514 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4515 lbound = gfc_conv_descriptor_lbound_get (tmp,
4519 lbound = gfc_conv_descriptor_lbound_get (dest,
4522 lbound = gfc_index_one_node;
4524 lbound = fold_convert (gfc_array_index_type, lbound);
4526 /* Shift the bounds and set the offset accordingly. */
4527 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4528 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4529 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4530 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4532 gfc_conv_descriptor_ubound_set (&block, dest,
4533 gfc_rank_cst[n], tmp);
4534 gfc_conv_descriptor_lbound_set (&block, dest,
4535 gfc_rank_cst[n], lbound);
4537 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4538 gfc_conv_descriptor_lbound_get (dest,
4540 gfc_conv_descriptor_stride_get (dest,
4542 gfc_add_modify (&block, tmp2, tmp);
4543 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4545 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4550 /* If a conversion expression has a null data pointer
4551 argument, nullify the allocatable component. */
4555 if (arg->symtree->n.sym->attr.allocatable
4556 || arg->symtree->n.sym->attr.pointer)
4558 non_null_expr = gfc_finish_block (&block);
4559 gfc_start_block (&block);
4560 gfc_conv_descriptor_data_set (&block, dest,
4562 null_expr = gfc_finish_block (&block);
4563 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4564 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4565 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4566 return build3_v (COND_EXPR, tmp,
4567 null_expr, non_null_expr);
4571 return gfc_finish_block (&block);
4575 /* Assign a single component of a derived type constructor. */
4578 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4586 gfc_start_block (&block);
4588 if (cm->attr.pointer)
4590 gfc_init_se (&se, NULL);
4591 /* Pointer component. */
4592 if (cm->attr.dimension)
4594 /* Array pointer. */
4595 if (expr->expr_type == EXPR_NULL)
4596 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4599 rss = gfc_walk_expr (expr);
4600 se.direct_byref = 1;
4602 gfc_conv_expr_descriptor (&se, expr, rss);
4603 gfc_add_block_to_block (&block, &se.pre);
4604 gfc_add_block_to_block (&block, &se.post);
4609 /* Scalar pointers. */
4610 se.want_pointer = 1;
4611 gfc_conv_expr (&se, expr);
4612 gfc_add_block_to_block (&block, &se.pre);
4613 gfc_add_modify (&block, dest,
4614 fold_convert (TREE_TYPE (dest), se.expr));
4615 gfc_add_block_to_block (&block, &se.post);
4618 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4620 /* NULL initialization for CLASS components. */
4621 tmp = gfc_trans_structure_assign (dest,
4622 gfc_class_null_initializer (&cm->ts));
4623 gfc_add_expr_to_block (&block, tmp);
4625 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4627 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4628 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4629 else if (cm->attr.allocatable)
4631 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4632 gfc_add_expr_to_block (&block, tmp);
4636 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4637 gfc_add_expr_to_block (&block, tmp);
4640 else if (expr->ts.type == BT_DERIVED)
4642 if (expr->expr_type != EXPR_STRUCTURE)
4644 gfc_init_se (&se, NULL);
4645 gfc_conv_expr (&se, expr);
4646 gfc_add_block_to_block (&block, &se.pre);
4647 gfc_add_modify (&block, dest,
4648 fold_convert (TREE_TYPE (dest), se.expr));
4649 gfc_add_block_to_block (&block, &se.post);
4653 /* Nested constructors. */
4654 tmp = gfc_trans_structure_assign (dest, expr);
4655 gfc_add_expr_to_block (&block, tmp);
4660 /* Scalar component. */
4661 gfc_init_se (&se, NULL);
4662 gfc_init_se (&lse, NULL);
4664 gfc_conv_expr (&se, expr);
4665 if (cm->ts.type == BT_CHARACTER)
4666 lse.string_length = cm->ts.u.cl->backend_decl;
4668 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4669 gfc_add_expr_to_block (&block, tmp);
4671 return gfc_finish_block (&block);
4674 /* Assign a derived type constructor to a variable. */
4677 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4685 gfc_start_block (&block);
4686 cm = expr->ts.u.derived->components;
4688 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4689 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4690 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4694 gcc_assert (cm->backend_decl == NULL);
4695 gfc_init_se (&se, NULL);
4696 gfc_init_se (&lse, NULL);
4697 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4699 gfc_add_modify (&block, lse.expr,
4700 fold_convert (TREE_TYPE (lse.expr), se.expr));
4702 return gfc_finish_block (&block);
4705 for (c = gfc_constructor_first (expr->value.constructor);
4706 c; c = gfc_constructor_next (c), cm = cm->next)
4708 /* Skip absent members in default initializers. */
4712 field = cm->backend_decl;
4713 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4714 dest, field, NULL_TREE);
4715 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4716 gfc_add_expr_to_block (&block, tmp);
4718 return gfc_finish_block (&block);
4721 /* Build an expression for a constructor. If init is nonzero then
4722 this is part of a static variable initializer. */
4725 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4732 VEC(constructor_elt,gc) *v = NULL;
4734 gcc_assert (se->ss == NULL);
4735 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4736 type = gfc_typenode_for_spec (&expr->ts);
4740 /* Create a temporary variable and fill it in. */
4741 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4742 tmp = gfc_trans_structure_assign (se->expr, expr);
4743 gfc_add_expr_to_block (&se->pre, tmp);
4747 cm = expr->ts.u.derived->components;
4749 for (c = gfc_constructor_first (expr->value.constructor);
4750 c; c = gfc_constructor_next (c), cm = cm->next)
4752 /* Skip absent members in default initializers and allocatable
4753 components. Although the latter have a default initializer
4754 of EXPR_NULL,... by default, the static nullify is not needed
4755 since this is done every time we come into scope. */
4756 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4759 if (strcmp (cm->name, "_size") == 0)
4761 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4762 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4764 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4765 && strcmp (cm->name, "_extends") == 0)
4769 vtabs = cm->initializer->symtree->n.sym;
4770 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4771 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4775 val = gfc_conv_initializer (c->expr, &cm->ts,
4776 TREE_TYPE (cm->backend_decl),
4777 cm->attr.dimension, cm->attr.pointer,
4778 cm->attr.proc_pointer);
4780 /* Append it to the constructor list. */
4781 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4784 se->expr = build_constructor (type, v);
4786 TREE_CONSTANT (se->expr) = 1;
4790 /* Translate a substring expression. */
4793 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4799 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4801 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4802 expr->value.character.length,
4803 expr->value.character.string);
4805 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4806 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4809 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4813 /* Entry point for expression translation. Evaluates a scalar quantity.
4814 EXPR is the expression to be translated, and SE is the state structure if
4815 called from within the scalarized. */
4818 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4820 if (se->ss && se->ss->expr == expr
4821 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4823 /* Substitute a scalar expression evaluated outside the scalarization
4825 se->expr = se->ss->data.scalar.expr;
4826 if (se->ss->type == GFC_SS_REFERENCE)
4827 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4828 se->string_length = se->ss->string_length;
4829 gfc_advance_se_ss_chain (se);
4833 /* We need to convert the expressions for the iso_c_binding derived types.
4834 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4835 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4836 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4837 updated to be an integer with a kind equal to the size of a (void *). */
4838 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4839 && expr->ts.u.derived->attr.is_iso_c)
4841 if (expr->expr_type == EXPR_VARIABLE
4842 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4843 || expr->symtree->n.sym->intmod_sym_id
4844 == ISOCBINDING_NULL_FUNPTR))
4846 /* Set expr_type to EXPR_NULL, which will result in
4847 null_pointer_node being used below. */
4848 expr->expr_type = EXPR_NULL;
4852 /* Update the type/kind of the expression to be what the new
4853 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4854 expr->ts.type = expr->ts.u.derived->ts.type;
4855 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4856 expr->ts.kind = expr->ts.u.derived->ts.kind;
4860 switch (expr->expr_type)
4863 gfc_conv_expr_op (se, expr);
4867 gfc_conv_function_expr (se, expr);
4871 gfc_conv_constant (se, expr);
4875 gfc_conv_variable (se, expr);
4879 se->expr = null_pointer_node;
4882 case EXPR_SUBSTRING:
4883 gfc_conv_substring_expr (se, expr);
4886 case EXPR_STRUCTURE:
4887 gfc_conv_structure (se, expr, 0);
4891 gfc_conv_array_constructor_expr (se, expr);
4900 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4901 of an assignment. */
4903 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4905 gfc_conv_expr (se, expr);
4906 /* All numeric lvalues should have empty post chains. If not we need to
4907 figure out a way of rewriting an lvalue so that it has no post chain. */
4908 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4911 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4912 numeric expressions. Used for scalar values where inserting cleanup code
4915 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4919 gcc_assert (expr->ts.type != BT_CHARACTER);
4920 gfc_conv_expr (se, expr);
4923 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4924 gfc_add_modify (&se->pre, val, se->expr);
4926 gfc_add_block_to_block (&se->pre, &se->post);
4930 /* Helper to translate an expression and convert it to a particular type. */
4932 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4934 gfc_conv_expr_val (se, expr);
4935 se->expr = convert (type, se->expr);
4939 /* Converts an expression so that it can be passed by reference. Scalar
4943 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4947 if (se->ss && se->ss->expr == expr
4948 && se->ss->type == GFC_SS_REFERENCE)
4950 /* Returns a reference to the scalar evaluated outside the loop
4952 gfc_conv_expr (se, expr);
4956 if (expr->ts.type == BT_CHARACTER)
4958 gfc_conv_expr (se, expr);
4959 gfc_conv_string_parameter (se);
4963 if (expr->expr_type == EXPR_VARIABLE)
4965 se->want_pointer = 1;
4966 gfc_conv_expr (se, expr);
4969 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4970 gfc_add_modify (&se->pre, var, se->expr);
4971 gfc_add_block_to_block (&se->pre, &se->post);
4977 if (expr->expr_type == EXPR_FUNCTION
4978 && ((expr->value.function.esym
4979 && expr->value.function.esym->result->attr.pointer
4980 && !expr->value.function.esym->result->attr.dimension)
4981 || (!expr->value.function.esym
4982 && expr->symtree->n.sym->attr.pointer
4983 && !expr->symtree->n.sym->attr.dimension)))
4985 se->want_pointer = 1;
4986 gfc_conv_expr (se, expr);
4987 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4988 gfc_add_modify (&se->pre, var, se->expr);
4994 gfc_conv_expr (se, expr);
4996 /* Create a temporary var to hold the value. */
4997 if (TREE_CONSTANT (se->expr))
4999 tree tmp = se->expr;
5000 STRIP_TYPE_NOPS (tmp);
5001 var = build_decl (input_location,
5002 CONST_DECL, NULL, TREE_TYPE (tmp));
5003 DECL_INITIAL (var) = tmp;
5004 TREE_STATIC (var) = 1;
5009 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5010 gfc_add_modify (&se->pre, var, se->expr);
5012 gfc_add_block_to_block (&se->pre, &se->post);
5014 /* Take the address of that value. */
5015 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5020 gfc_trans_pointer_assign (gfc_code * code)
5022 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5026 /* Generate code for a pointer assignment. */
5029 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5040 gfc_start_block (&block);
5042 gfc_init_se (&lse, NULL);
5044 lss = gfc_walk_expr (expr1);
5045 rss = gfc_walk_expr (expr2);
5046 if (lss == gfc_ss_terminator)
5048 /* Scalar pointers. */
5049 lse.want_pointer = 1;
5050 gfc_conv_expr (&lse, expr1);
5051 gcc_assert (rss == gfc_ss_terminator);
5052 gfc_init_se (&rse, NULL);
5053 rse.want_pointer = 1;
5054 gfc_conv_expr (&rse, expr2);
5056 if (expr1->symtree->n.sym->attr.proc_pointer
5057 && expr1->symtree->n.sym->attr.dummy)
5058 lse.expr = build_fold_indirect_ref_loc (input_location,
5061 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5062 && expr2->symtree->n.sym->attr.dummy)
5063 rse.expr = build_fold_indirect_ref_loc (input_location,
5066 gfc_add_block_to_block (&block, &lse.pre);
5067 gfc_add_block_to_block (&block, &rse.pre);
5069 /* Check character lengths if character expression. The test is only
5070 really added if -fbounds-check is enabled. Exclude deferred
5071 character length lefthand sides. */
5072 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5073 && !(expr1->ts.deferred
5074 && (TREE_CODE (lse.string_length) == VAR_DECL))
5075 && !expr1->symtree->n.sym->attr.proc_pointer
5076 && !gfc_is_proc_ptr_comp (expr1, NULL))
5078 gcc_assert (expr2->ts.type == BT_CHARACTER);
5079 gcc_assert (lse.string_length && rse.string_length);
5080 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5081 lse.string_length, rse.string_length,
5085 /* The assignment to an deferred character length sets the string
5086 length to that of the rhs. */
5087 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5089 if (expr2->expr_type != EXPR_NULL)
5090 gfc_add_modify (&block, lse.string_length, rse.string_length);
5092 gfc_add_modify (&block, lse.string_length,
5093 build_int_cst (gfc_charlen_type_node, 0));
5096 gfc_add_modify (&block, lse.expr,
5097 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5099 gfc_add_block_to_block (&block, &rse.post);
5100 gfc_add_block_to_block (&block, &lse.post);
5107 tree strlen_rhs = NULL_TREE;
5109 /* Array pointer. Find the last reference on the LHS and if it is an
5110 array section ref, we're dealing with bounds remapping. In this case,
5111 set it to AR_FULL so that gfc_conv_expr_descriptor does
5112 not see it and process the bounds remapping afterwards explicitely. */
5113 for (remap = expr1->ref; remap; remap = remap->next)
5114 if (!remap->next && remap->type == REF_ARRAY
5115 && remap->u.ar.type == AR_SECTION)
5117 remap->u.ar.type = AR_FULL;
5120 rank_remap = (remap && remap->u.ar.end[0]);
5122 gfc_conv_expr_descriptor (&lse, expr1, lss);
5123 strlen_lhs = lse.string_length;
5126 if (expr2->expr_type == EXPR_NULL)
5128 /* Just set the data pointer to null. */
5129 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5131 else if (rank_remap)
5133 /* If we are rank-remapping, just get the RHS's descriptor and
5134 process this later on. */
5135 gfc_init_se (&rse, NULL);
5136 rse.direct_byref = 1;
5137 rse.byref_noassign = 1;
5138 gfc_conv_expr_descriptor (&rse, expr2, rss);
5139 strlen_rhs = rse.string_length;
5141 else if (expr2->expr_type == EXPR_VARIABLE)
5143 /* Assign directly to the LHS's descriptor. */
5144 lse.direct_byref = 1;
5145 gfc_conv_expr_descriptor (&lse, expr2, rss);
5146 strlen_rhs = lse.string_length;
5148 /* If this is a subreference array pointer assignment, use the rhs
5149 descriptor element size for the lhs span. */
5150 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5152 decl = expr1->symtree->n.sym->backend_decl;
5153 gfc_init_se (&rse, NULL);
5154 rse.descriptor_only = 1;
5155 gfc_conv_expr (&rse, expr2);
5156 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5157 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5158 if (!INTEGER_CST_P (tmp))
5159 gfc_add_block_to_block (&lse.post, &rse.pre);
5160 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5165 /* Assign to a temporary descriptor and then copy that
5166 temporary to the pointer. */
5167 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5170 lse.direct_byref = 1;
5171 gfc_conv_expr_descriptor (&lse, expr2, rss);
5172 strlen_rhs = lse.string_length;
5173 gfc_add_modify (&lse.pre, desc, tmp);
5176 gfc_add_block_to_block (&block, &lse.pre);
5178 gfc_add_block_to_block (&block, &rse.pre);
5180 /* If we do bounds remapping, update LHS descriptor accordingly. */
5184 gcc_assert (remap->u.ar.dimen == expr1->rank);
5188 /* Do rank remapping. We already have the RHS's descriptor
5189 converted in rse and now have to build the correct LHS
5190 descriptor for it. */
5194 tree lbound, ubound;
5197 dtype = gfc_conv_descriptor_dtype (desc);
5198 tmp = gfc_get_dtype (TREE_TYPE (desc));
5199 gfc_add_modify (&block, dtype, tmp);
5201 /* Copy data pointer. */
5202 data = gfc_conv_descriptor_data_get (rse.expr);
5203 gfc_conv_descriptor_data_set (&block, desc, data);
5205 /* Copy offset but adjust it such that it would correspond
5206 to a lbound of zero. */
5207 offs = gfc_conv_descriptor_offset_get (rse.expr);
5208 for (dim = 0; dim < expr2->rank; ++dim)
5210 stride = gfc_conv_descriptor_stride_get (rse.expr,
5212 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5214 tmp = fold_build2_loc (input_location, MULT_EXPR,
5215 gfc_array_index_type, stride, lbound);
5216 offs = fold_build2_loc (input_location, PLUS_EXPR,
5217 gfc_array_index_type, offs, tmp);
5219 gfc_conv_descriptor_offset_set (&block, desc, offs);
5221 /* Set the bounds as declared for the LHS and calculate strides as
5222 well as another offset update accordingly. */
5223 stride = gfc_conv_descriptor_stride_get (rse.expr,
5225 for (dim = 0; dim < expr1->rank; ++dim)
5230 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5232 /* Convert declared bounds. */
5233 gfc_init_se (&lower_se, NULL);
5234 gfc_init_se (&upper_se, NULL);
5235 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5236 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5238 gfc_add_block_to_block (&block, &lower_se.pre);
5239 gfc_add_block_to_block (&block, &upper_se.pre);
5241 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5242 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5244 lbound = gfc_evaluate_now (lbound, &block);
5245 ubound = gfc_evaluate_now (ubound, &block);
5247 gfc_add_block_to_block (&block, &lower_se.post);
5248 gfc_add_block_to_block (&block, &upper_se.post);
5250 /* Set bounds in descriptor. */
5251 gfc_conv_descriptor_lbound_set (&block, desc,
5252 gfc_rank_cst[dim], lbound);
5253 gfc_conv_descriptor_ubound_set (&block, desc,
5254 gfc_rank_cst[dim], ubound);
5257 stride = gfc_evaluate_now (stride, &block);
5258 gfc_conv_descriptor_stride_set (&block, desc,
5259 gfc_rank_cst[dim], stride);
5261 /* Update offset. */
5262 offs = gfc_conv_descriptor_offset_get (desc);
5263 tmp = fold_build2_loc (input_location, MULT_EXPR,
5264 gfc_array_index_type, lbound, stride);
5265 offs = fold_build2_loc (input_location, MINUS_EXPR,
5266 gfc_array_index_type, offs, tmp);
5267 offs = gfc_evaluate_now (offs, &block);
5268 gfc_conv_descriptor_offset_set (&block, desc, offs);
5270 /* Update stride. */
5271 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5272 stride = fold_build2_loc (input_location, MULT_EXPR,
5273 gfc_array_index_type, stride, tmp);
5278 /* Bounds remapping. Just shift the lower bounds. */
5280 gcc_assert (expr1->rank == expr2->rank);
5282 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5286 gcc_assert (remap->u.ar.start[dim]);
5287 gcc_assert (!remap->u.ar.end[dim]);
5288 gfc_init_se (&lbound_se, NULL);
5289 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5291 gfc_add_block_to_block (&block, &lbound_se.pre);
5292 gfc_conv_shift_descriptor_lbound (&block, desc,
5293 dim, lbound_se.expr);
5294 gfc_add_block_to_block (&block, &lbound_se.post);
5299 /* Check string lengths if applicable. The check is only really added
5300 to the output code if -fbounds-check is enabled. */
5301 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5303 gcc_assert (expr2->ts.type == BT_CHARACTER);
5304 gcc_assert (strlen_lhs && strlen_rhs);
5305 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5306 strlen_lhs, strlen_rhs, &block);
5309 /* If rank remapping was done, check with -fcheck=bounds that
5310 the target is at least as large as the pointer. */
5311 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5317 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5318 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5320 lsize = gfc_evaluate_now (lsize, &block);
5321 rsize = gfc_evaluate_now (rsize, &block);
5322 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5325 msg = _("Target of rank remapping is too small (%ld < %ld)");
5326 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5330 gfc_add_block_to_block (&block, &lse.post);
5332 gfc_add_block_to_block (&block, &rse.post);
5335 return gfc_finish_block (&block);
5339 /* Makes sure se is suitable for passing as a function string parameter. */
5340 /* TODO: Need to check all callers of this function. It may be abused. */
5343 gfc_conv_string_parameter (gfc_se * se)
5347 if (TREE_CODE (se->expr) == STRING_CST)
5349 type = TREE_TYPE (TREE_TYPE (se->expr));
5350 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5354 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5356 if (TREE_CODE (se->expr) != INDIRECT_REF)
5358 type = TREE_TYPE (se->expr);
5359 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5363 type = gfc_get_character_type_len (gfc_default_character_kind,
5365 type = build_pointer_type (type);
5366 se->expr = gfc_build_addr_expr (type, se->expr);
5370 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5374 /* Generate code for assignment of scalar variables. Includes character
5375 strings and derived types with allocatable components.
5376 If you know that the LHS has no allocations, set dealloc to false. */
5379 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5380 bool l_is_temp, bool r_is_var, bool dealloc)
5386 gfc_init_block (&block);
5388 if (ts.type == BT_CHARACTER)
5393 if (lse->string_length != NULL_TREE)
5395 gfc_conv_string_parameter (lse);
5396 gfc_add_block_to_block (&block, &lse->pre);
5397 llen = lse->string_length;
5400 if (rse->string_length != NULL_TREE)
5402 gcc_assert (rse->string_length != NULL_TREE);
5403 gfc_conv_string_parameter (rse);
5404 gfc_add_block_to_block (&block, &rse->pre);
5405 rlen = rse->string_length;
5408 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5409 rse->expr, ts.kind);
5411 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5415 /* Are the rhs and the lhs the same? */
5418 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5419 gfc_build_addr_expr (NULL_TREE, lse->expr),
5420 gfc_build_addr_expr (NULL_TREE, rse->expr));
5421 cond = gfc_evaluate_now (cond, &lse->pre);
5424 /* Deallocate the lhs allocated components as long as it is not
5425 the same as the rhs. This must be done following the assignment
5426 to prevent deallocating data that could be used in the rhs
5428 if (!l_is_temp && dealloc)
5430 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5431 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5433 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5435 gfc_add_expr_to_block (&lse->post, tmp);
5438 gfc_add_block_to_block (&block, &rse->pre);
5439 gfc_add_block_to_block (&block, &lse->pre);
5441 gfc_add_modify (&block, lse->expr,
5442 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5444 /* Do a deep copy if the rhs is a variable, if it is not the
5448 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5449 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5451 gfc_add_expr_to_block (&block, tmp);
5454 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5456 gfc_add_block_to_block (&block, &lse->pre);
5457 gfc_add_block_to_block (&block, &rse->pre);
5458 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5459 TREE_TYPE (lse->expr), rse->expr);
5460 gfc_add_modify (&block, lse->expr, tmp);
5464 gfc_add_block_to_block (&block, &lse->pre);
5465 gfc_add_block_to_block (&block, &rse->pre);
5467 gfc_add_modify (&block, lse->expr,
5468 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5471 gfc_add_block_to_block (&block, &lse->post);
5472 gfc_add_block_to_block (&block, &rse->post);
5474 return gfc_finish_block (&block);
5478 /* There are quite a lot of restrictions on the optimisation in using an
5479 array function assign without a temporary. */
5482 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5485 bool seen_array_ref;
5487 gfc_symbol *sym = expr1->symtree->n.sym;
5489 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5490 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5493 /* Elemental functions are scalarized so that they don't need a
5494 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5495 they would need special treatment in gfc_trans_arrayfunc_assign. */
5496 if (expr2->value.function.esym != NULL
5497 && expr2->value.function.esym->attr.elemental)
5500 /* Need a temporary if rhs is not FULL or a contiguous section. */
5501 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5504 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5505 if (gfc_ref_needs_temporary_p (expr1->ref))
5508 /* Functions returning pointers or allocatables need temporaries. */
5509 c = expr2->value.function.esym
5510 ? (expr2->value.function.esym->attr.pointer
5511 || expr2->value.function.esym->attr.allocatable)
5512 : (expr2->symtree->n.sym->attr.pointer
5513 || expr2->symtree->n.sym->attr.allocatable);
5517 /* Character array functions need temporaries unless the
5518 character lengths are the same. */
5519 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5521 if (expr1->ts.u.cl->length == NULL
5522 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5525 if (expr2->ts.u.cl->length == NULL
5526 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5529 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5530 expr2->ts.u.cl->length->value.integer) != 0)
5534 /* Check that no LHS component references appear during an array
5535 reference. This is needed because we do not have the means to
5536 span any arbitrary stride with an array descriptor. This check
5537 is not needed for the rhs because the function result has to be
5539 seen_array_ref = false;
5540 for (ref = expr1->ref; ref; ref = ref->next)
5542 if (ref->type == REF_ARRAY)
5543 seen_array_ref= true;
5544 else if (ref->type == REF_COMPONENT && seen_array_ref)
5548 /* Check for a dependency. */
5549 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5550 expr2->value.function.esym,
5551 expr2->value.function.actual,
5555 /* If we have reached here with an intrinsic function, we do not
5556 need a temporary except in the particular case that reallocation
5557 on assignment is active and the lhs is allocatable and a target. */
5558 if (expr2->value.function.isym)
5559 return (gfc_option.flag_realloc_lhs
5560 && sym->attr.allocatable
5561 && sym->attr.target);
5563 /* If the LHS is a dummy, we need a temporary if it is not
5565 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5568 /* If the lhs has been host_associated, is in common, a pointer or is
5569 a target and the function is not using a RESULT variable, aliasing
5570 can occur and a temporary is needed. */
5571 if ((sym->attr.host_assoc
5572 || sym->attr.in_common
5573 || sym->attr.pointer
5574 || sym->attr.cray_pointee
5575 || sym->attr.target)
5576 && expr2->symtree != NULL
5577 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5580 /* A PURE function can unconditionally be called without a temporary. */
5581 if (expr2->value.function.esym != NULL
5582 && expr2->value.function.esym->attr.pure)
5585 /* Implicit_pure functions are those which could legally be declared
5587 if (expr2->value.function.esym != NULL
5588 && expr2->value.function.esym->attr.implicit_pure)
5591 if (!sym->attr.use_assoc
5592 && !sym->attr.in_common
5593 && !sym->attr.pointer
5594 && !sym->attr.target
5595 && !sym->attr.cray_pointee
5596 && expr2->value.function.esym)
5598 /* A temporary is not needed if the function is not contained and
5599 the variable is local or host associated and not a pointer or
5601 if (!expr2->value.function.esym->attr.contained)
5604 /* A temporary is not needed if the lhs has never been host
5605 associated and the procedure is contained. */
5606 else if (!sym->attr.host_assoc)
5609 /* A temporary is not needed if the variable is local and not
5610 a pointer, a target or a result. */
5612 && expr2->value.function.esym->ns == sym->ns->parent)
5616 /* Default to temporary use. */
5621 /* Provide the loop info so that the lhs descriptor can be built for
5622 reallocatable assignments from extrinsic function calls. */
5625 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5628 /* Signal that the function call should not be made by
5629 gfc_conv_loop_setup. */
5630 se->ss->is_alloc_lhs = 1;
5631 gfc_init_loopinfo (loop);
5632 gfc_add_ss_to_loop (loop, *ss);
5633 gfc_add_ss_to_loop (loop, se->ss);
5634 gfc_conv_ss_startstride (loop);
5635 gfc_conv_loop_setup (loop, where);
5636 gfc_copy_loopinfo_to_se (se, loop);
5637 gfc_add_block_to_block (&se->pre, &loop->pre);
5638 gfc_add_block_to_block (&se->pre, &loop->post);
5639 se->ss->is_alloc_lhs = 0;
5643 /* For Assignment to a reallocatable lhs from intrinsic functions,
5644 replace the se.expr (ie. the result) with a temporary descriptor.
5645 Null the data field so that the library allocates space for the
5646 result. Free the data of the original descriptor after the function,
5647 in case it appears in an argument expression and transfer the
5648 result to the original descriptor. */
5651 fcncall_realloc_result (gfc_se *se, int rank)
5659 /* Use the allocation done by the library. Substitute the lhs
5660 descriptor with a copy, whose data field is nulled.*/
5661 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5662 /* Unallocated, the descriptor does not have a dtype. */
5663 tmp = gfc_conv_descriptor_dtype (desc);
5664 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5665 res_desc = gfc_evaluate_now (desc, &se->pre);
5666 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5667 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5669 /* Free the lhs after the function call and copy the result to
5670 the lhs descriptor. */
5671 tmp = gfc_conv_descriptor_data_get (desc);
5672 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5673 gfc_add_expr_to_block (&se->post, tmp);
5674 gfc_add_modify (&se->post, desc, res_desc);
5676 offset = gfc_index_zero_node;
5677 tmp = gfc_index_one_node;
5678 /* Now reset the bounds from zero based to unity based. */
5679 for (n = 0 ; n < rank; n++)
5681 /* Accumulate the offset. */
5682 offset = fold_build2_loc (input_location, MINUS_EXPR,
5683 gfc_array_index_type,
5685 /* Now do the bounds. */
5686 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5687 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5688 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5689 gfc_array_index_type,
5690 tmp, gfc_index_one_node);
5691 gfc_conv_descriptor_lbound_set (&se->post, desc,
5693 gfc_index_one_node);
5694 gfc_conv_descriptor_ubound_set (&se->post, desc,
5695 gfc_rank_cst[n], tmp);
5697 /* The extent for the next contribution to offset. */
5698 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5699 gfc_array_index_type,
5700 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5701 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5702 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5703 gfc_array_index_type,
5704 tmp, gfc_index_one_node);
5706 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5711 /* Try to translate array(:) = func (...), where func is a transformational
5712 array function, without using a temporary. Returns NULL if this isn't the
5716 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5720 gfc_component *comp = NULL;
5723 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5726 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5728 gcc_assert (expr2->value.function.isym
5729 || (gfc_is_proc_ptr_comp (expr2, &comp)
5730 && comp && comp->attr.dimension)
5731 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5732 && expr2->value.function.esym->result->attr.dimension));
5734 ss = gfc_walk_expr (expr1);
5735 gcc_assert (ss != gfc_ss_terminator);
5736 gfc_init_se (&se, NULL);
5737 gfc_start_block (&se.pre);
5738 se.want_pointer = 1;
5740 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5742 if (expr1->ts.type == BT_DERIVED
5743 && expr1->ts.u.derived->attr.alloc_comp)
5746 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5748 gfc_add_expr_to_block (&se.pre, tmp);
5751 se.direct_byref = 1;
5752 se.ss = gfc_walk_expr (expr2);
5753 gcc_assert (se.ss != gfc_ss_terminator);
5755 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5756 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5757 Clearly, this cannot be done for an allocatable function result, since
5758 the shape of the result is unknown and, in any case, the function must
5759 correctly take care of the reallocation internally. For intrinsic
5760 calls, the array data is freed and the library takes care of allocation.
5761 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5763 if (gfc_option.flag_realloc_lhs
5764 && gfc_is_reallocatable_lhs (expr1)
5765 && !gfc_expr_attr (expr1).codimension
5766 && !gfc_is_coindexed (expr1)
5767 && !(expr2->value.function.esym
5768 && expr2->value.function.esym->result->attr.allocatable))
5770 if (!expr2->value.function.isym)
5772 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5773 ss->is_alloc_lhs = 1;
5776 fcncall_realloc_result (&se, expr1->rank);
5779 gfc_conv_function_expr (&se, expr2);
5780 gfc_add_block_to_block (&se.pre, &se.post);
5782 return gfc_finish_block (&se.pre);
5786 /* Try to efficiently translate array(:) = 0. Return NULL if this
5790 gfc_trans_zero_assign (gfc_expr * expr)
5792 tree dest, len, type;
5796 sym = expr->symtree->n.sym;
5797 dest = gfc_get_symbol_decl (sym);
5799 type = TREE_TYPE (dest);
5800 if (POINTER_TYPE_P (type))
5801 type = TREE_TYPE (type);
5802 if (!GFC_ARRAY_TYPE_P (type))
5805 /* Determine the length of the array. */
5806 len = GFC_TYPE_ARRAY_SIZE (type);
5807 if (!len || TREE_CODE (len) != INTEGER_CST)
5810 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5811 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5812 fold_convert (gfc_array_index_type, tmp));
5814 /* If we are zeroing a local array avoid taking its address by emitting
5816 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5817 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5818 dest, build_constructor (TREE_TYPE (dest), NULL));
5820 /* Convert arguments to the correct types. */
5821 dest = fold_convert (pvoid_type_node, dest);
5822 len = fold_convert (size_type_node, len);
5824 /* Construct call to __builtin_memset. */
5825 tmp = build_call_expr_loc (input_location,
5826 builtin_decl_explicit (BUILT_IN_MEMSET),
5827 3, dest, integer_zero_node, len);
5828 return fold_convert (void_type_node, tmp);
5832 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5833 that constructs the call to __builtin_memcpy. */
5836 gfc_build_memcpy_call (tree dst, tree src, tree len)
5840 /* Convert arguments to the correct types. */
5841 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5842 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5844 dst = fold_convert (pvoid_type_node, dst);
5846 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5847 src = gfc_build_addr_expr (pvoid_type_node, src);
5849 src = fold_convert (pvoid_type_node, src);
5851 len = fold_convert (size_type_node, len);
5853 /* Construct call to __builtin_memcpy. */
5854 tmp = build_call_expr_loc (input_location,
5855 builtin_decl_explicit (BUILT_IN_MEMCPY),
5857 return fold_convert (void_type_node, tmp);
5861 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5862 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5863 source/rhs, both are gfc_full_array_ref_p which have been checked for
5867 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5869 tree dst, dlen, dtype;
5870 tree src, slen, stype;
5873 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5874 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5876 dtype = TREE_TYPE (dst);
5877 if (POINTER_TYPE_P (dtype))
5878 dtype = TREE_TYPE (dtype);
5879 stype = TREE_TYPE (src);
5880 if (POINTER_TYPE_P (stype))
5881 stype = TREE_TYPE (stype);
5883 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5886 /* Determine the lengths of the arrays. */
5887 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5888 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5890 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5891 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5892 dlen, fold_convert (gfc_array_index_type, tmp));
5894 slen = GFC_TYPE_ARRAY_SIZE (stype);
5895 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5897 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5898 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5899 slen, fold_convert (gfc_array_index_type, tmp));
5901 /* Sanity check that they are the same. This should always be
5902 the case, as we should already have checked for conformance. */
5903 if (!tree_int_cst_equal (slen, dlen))
5906 return gfc_build_memcpy_call (dst, src, dlen);
5910 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5911 this can't be done. EXPR1 is the destination/lhs for which
5912 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5915 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5917 unsigned HOST_WIDE_INT nelem;
5923 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5927 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5928 dtype = TREE_TYPE (dst);
5929 if (POINTER_TYPE_P (dtype))
5930 dtype = TREE_TYPE (dtype);
5931 if (!GFC_ARRAY_TYPE_P (dtype))
5934 /* Determine the lengths of the array. */
5935 len = GFC_TYPE_ARRAY_SIZE (dtype);
5936 if (!len || TREE_CODE (len) != INTEGER_CST)
5939 /* Confirm that the constructor is the same size. */
5940 if (compare_tree_int (len, nelem) != 0)
5943 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5944 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5945 fold_convert (gfc_array_index_type, tmp));
5947 stype = gfc_typenode_for_spec (&expr2->ts);
5948 src = gfc_build_constant_array_constructor (expr2, stype);
5950 stype = TREE_TYPE (src);
5951 if (POINTER_TYPE_P (stype))
5952 stype = TREE_TYPE (stype);
5954 return gfc_build_memcpy_call (dst, src, len);
5958 /* Tells whether the expression is to be treated as a variable reference. */
5961 expr_is_variable (gfc_expr *expr)
5965 if (expr->expr_type == EXPR_VARIABLE)
5968 arg = gfc_get_noncopying_intrinsic_argument (expr);
5971 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5972 return expr_is_variable (arg);
5979 /* Is the lhs OK for automatic reallocation? */
5982 is_scalar_reallocatable_lhs (gfc_expr *expr)
5986 /* An allocatable variable with no reference. */
5987 if (expr->symtree->n.sym->attr.allocatable
5991 /* All that can be left are allocatable components. */
5992 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5993 && expr->symtree->n.sym->ts.type != BT_CLASS)
5994 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5997 /* Find an allocatable component ref last. */
5998 for (ref = expr->ref; ref; ref = ref->next)
5999 if (ref->type == REF_COMPONENT
6001 && ref->u.c.component->attr.allocatable)
6008 /* Allocate or reallocate scalar lhs, as necessary. */
6011 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6025 if (!expr1 || expr1->rank)
6028 if (!expr2 || expr2->rank)
6031 /* Since this is a scalar lhs, we can afford to do this. That is,
6032 there is no risk of side effects being repeated. */
6033 gfc_init_se (&lse, NULL);
6034 lse.want_pointer = 1;
6035 gfc_conv_expr (&lse, expr1);
6037 jump_label1 = gfc_build_label_decl (NULL_TREE);
6038 jump_label2 = gfc_build_label_decl (NULL_TREE);
6040 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6041 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6042 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6044 tmp = build3_v (COND_EXPR, cond,
6045 build1_v (GOTO_EXPR, jump_label1),
6046 build_empty_stmt (input_location));
6047 gfc_add_expr_to_block (block, tmp);
6049 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6051 /* Use the rhs string length and the lhs element size. */
6052 size = string_length;
6053 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6054 tmp = TYPE_SIZE_UNIT (tmp);
6055 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6056 TREE_TYPE (tmp), tmp,
6057 fold_convert (TREE_TYPE (tmp), size));
6061 /* Otherwise use the length in bytes of the rhs. */
6062 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6063 size_in_bytes = size;
6066 tmp = build_call_expr_loc (input_location,
6067 builtin_decl_explicit (BUILT_IN_MALLOC),
6069 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6070 gfc_add_modify (block, lse.expr, tmp);
6071 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6073 /* Deferred characters need checking for lhs and rhs string
6074 length. Other deferred parameter variables will have to
6076 tmp = build1_v (GOTO_EXPR, jump_label2);
6077 gfc_add_expr_to_block (block, tmp);
6079 tmp = build1_v (LABEL_EXPR, jump_label1);
6080 gfc_add_expr_to_block (block, tmp);
6082 /* For a deferred length character, reallocate if lengths of lhs and
6083 rhs are different. */
6084 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6086 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6087 expr1->ts.u.cl->backend_decl, size);
6088 /* Jump past the realloc if the lengths are the same. */
6089 tmp = build3_v (COND_EXPR, cond,
6090 build1_v (GOTO_EXPR, jump_label2),
6091 build_empty_stmt (input_location));
6092 gfc_add_expr_to_block (block, tmp);
6093 tmp = build_call_expr_loc (input_location,
6094 builtin_decl_explicit (BUILT_IN_REALLOC),
6095 2, fold_convert (pvoid_type_node, lse.expr),
6097 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6098 gfc_add_modify (block, lse.expr, tmp);
6099 tmp = build1_v (LABEL_EXPR, jump_label2);
6100 gfc_add_expr_to_block (block, tmp);
6102 /* Update the lhs character length. */
6103 size = string_length;
6104 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6109 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6110 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6111 init_flag indicates initialization expressions and dealloc that no
6112 deallocate prior assignment is needed (if in doubt, set true). */
6115 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6121 gfc_ss *lss_section;
6128 bool scalar_to_array;
6133 /* Assignment of the form lhs = rhs. */
6134 gfc_start_block (&block);
6136 gfc_init_se (&lse, NULL);
6137 gfc_init_se (&rse, NULL);
6140 lss = gfc_walk_expr (expr1);
6141 if (gfc_is_reallocatable_lhs (expr1)
6142 && !(expr2->expr_type == EXPR_FUNCTION
6143 && expr2->value.function.isym != NULL))
6144 lss->is_alloc_lhs = 1;
6146 if (lss != gfc_ss_terminator)
6148 /* The assignment needs scalarization. */
6151 /* Find a non-scalar SS from the lhs. */
6152 while (lss_section != gfc_ss_terminator
6153 && lss_section->type != GFC_SS_SECTION)
6154 lss_section = lss_section->next;
6156 gcc_assert (lss_section != gfc_ss_terminator);
6158 /* Initialize the scalarizer. */
6159 gfc_init_loopinfo (&loop);
6162 rss = gfc_walk_expr (expr2);
6163 if (rss == gfc_ss_terminator)
6164 /* The rhs is scalar. Add a ss for the expression. */
6165 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6167 /* Associate the SS with the loop. */
6168 gfc_add_ss_to_loop (&loop, lss);
6169 gfc_add_ss_to_loop (&loop, rss);
6171 /* Calculate the bounds of the scalarization. */
6172 gfc_conv_ss_startstride (&loop);
6173 /* Enable loop reversal. */
6174 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6175 loop.reverse[n] = GFC_ENABLE_REVERSE;
6176 /* Resolve any data dependencies in the statement. */
6177 gfc_conv_resolve_dependencies (&loop, lss, rss);
6178 /* Setup the scalarizing loops. */
6179 gfc_conv_loop_setup (&loop, &expr2->where);
6181 /* Setup the gfc_se structures. */
6182 gfc_copy_loopinfo_to_se (&lse, &loop);
6183 gfc_copy_loopinfo_to_se (&rse, &loop);
6186 gfc_mark_ss_chain_used (rss, 1);
6187 if (loop.temp_ss == NULL)
6190 gfc_mark_ss_chain_used (lss, 1);
6194 lse.ss = loop.temp_ss;
6195 gfc_mark_ss_chain_used (lss, 3);
6196 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6199 /* Allow the scalarizer to workshare array assignments. */
6200 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6201 ompws_flags |= OMPWS_SCALARIZER_WS;
6203 /* Start the scalarized loop body. */
6204 gfc_start_scalarized_body (&loop, &body);
6207 gfc_init_block (&body);
6209 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6211 /* Translate the expression. */
6212 gfc_conv_expr (&rse, expr2);
6214 /* Stabilize a string length for temporaries. */
6215 if (expr2->ts.type == BT_CHARACTER)
6216 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6218 string_length = NULL_TREE;
6222 gfc_conv_tmp_array_ref (&lse);
6223 if (expr2->ts.type == BT_CHARACTER)
6224 lse.string_length = string_length;
6227 gfc_conv_expr (&lse, expr1);
6229 /* Assignments of scalar derived types with allocatable components
6230 to arrays must be done with a deep copy and the rhs temporary
6231 must have its components deallocated afterwards. */
6232 scalar_to_array = (expr2->ts.type == BT_DERIVED
6233 && expr2->ts.u.derived->attr.alloc_comp
6234 && !expr_is_variable (expr2)
6235 && !gfc_is_constant_expr (expr2)
6236 && expr1->rank && !expr2->rank);
6237 if (scalar_to_array && dealloc)
6239 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6240 gfc_add_expr_to_block (&loop.post, tmp);
6243 /* For a deferred character length function, the function call must
6244 happen before the (re)allocation of the lhs, otherwise the character
6245 length of the result is not known. */
6246 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6247 || (expr2->expr_type == EXPR_COMPCALL)
6248 || (expr2->expr_type == EXPR_PPC))
6249 && expr2->ts.deferred);
6250 if (gfc_option.flag_realloc_lhs
6251 && expr2->ts.type == BT_CHARACTER
6252 && (def_clen_func || expr2->expr_type == EXPR_OP)
6253 && expr1->ts.deferred)
6254 gfc_add_block_to_block (&block, &rse.pre);
6256 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6257 l_is_temp || init_flag,
6258 expr_is_variable (expr2) || scalar_to_array
6259 || expr2->expr_type == EXPR_ARRAY, dealloc);
6260 gfc_add_expr_to_block (&body, tmp);
6262 if (lss == gfc_ss_terminator)
6264 /* F2003: Add the code for reallocation on assignment. */
6265 if (gfc_option.flag_realloc_lhs
6266 && is_scalar_reallocatable_lhs (expr1))
6267 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6270 /* Use the scalar assignment as is. */
6271 gfc_add_block_to_block (&block, &body);
6275 gcc_assert (lse.ss == gfc_ss_terminator
6276 && rse.ss == gfc_ss_terminator);
6280 gfc_trans_scalarized_loop_boundary (&loop, &body);
6282 /* We need to copy the temporary to the actual lhs. */
6283 gfc_init_se (&lse, NULL);
6284 gfc_init_se (&rse, NULL);
6285 gfc_copy_loopinfo_to_se (&lse, &loop);
6286 gfc_copy_loopinfo_to_se (&rse, &loop);
6288 rse.ss = loop.temp_ss;
6291 gfc_conv_tmp_array_ref (&rse);
6292 gfc_conv_expr (&lse, expr1);
6294 gcc_assert (lse.ss == gfc_ss_terminator
6295 && rse.ss == gfc_ss_terminator);
6297 if (expr2->ts.type == BT_CHARACTER)
6298 rse.string_length = string_length;
6300 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6301 false, false, dealloc);
6302 gfc_add_expr_to_block (&body, tmp);
6305 /* F2003: Allocate or reallocate lhs of allocatable array. */
6306 if (gfc_option.flag_realloc_lhs
6307 && gfc_is_reallocatable_lhs (expr1)
6308 && !gfc_expr_attr (expr1).codimension
6309 && !gfc_is_coindexed (expr1))
6311 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6312 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6313 if (tmp != NULL_TREE)
6314 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6317 /* Generate the copying loops. */
6318 gfc_trans_scalarizing_loops (&loop, &body);
6320 /* Wrap the whole thing up. */
6321 gfc_add_block_to_block (&block, &loop.pre);
6322 gfc_add_block_to_block (&block, &loop.post);
6324 gfc_cleanup_loop (&loop);
6327 return gfc_finish_block (&block);
6331 /* Check whether EXPR is a copyable array. */
6334 copyable_array_p (gfc_expr * expr)
6336 if (expr->expr_type != EXPR_VARIABLE)
6339 /* First check it's an array. */
6340 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6343 if (!gfc_full_array_ref_p (expr->ref, NULL))
6346 /* Next check that it's of a simple enough type. */
6347 switch (expr->ts.type)
6359 return !expr->ts.u.derived->attr.alloc_comp;
6368 /* Translate an assignment. */
6371 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6376 /* Special case a single function returning an array. */
6377 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6379 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6384 /* Special case assigning an array to zero. */
6385 if (copyable_array_p (expr1)
6386 && is_zero_initializer_p (expr2))
6388 tmp = gfc_trans_zero_assign (expr1);
6393 /* Special case copying one array to another. */
6394 if (copyable_array_p (expr1)
6395 && copyable_array_p (expr2)
6396 && gfc_compare_types (&expr1->ts, &expr2->ts)
6397 && !gfc_check_dependency (expr1, expr2, 0))
6399 tmp = gfc_trans_array_copy (expr1, expr2);
6404 /* Special case initializing an array from a constant array constructor. */
6405 if (copyable_array_p (expr1)
6406 && expr2->expr_type == EXPR_ARRAY
6407 && gfc_compare_types (&expr1->ts, &expr2->ts))
6409 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6414 /* Fallback to the scalarizer to generate explicit loops. */
6415 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6419 gfc_trans_init_assign (gfc_code * code)
6421 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6425 gfc_trans_assign (gfc_code * code)
6427 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6431 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6432 A MEMCPY is needed to copy the full data from the default initializer
6433 of the dynamic type. */
6436 gfc_trans_class_init_assign (gfc_code *code)
6440 gfc_se dst,src,memsz;
6441 gfc_expr *lhs,*rhs,*sz;
6443 gfc_start_block (&block);
6445 lhs = gfc_copy_expr (code->expr1);
6446 gfc_add_data_component (lhs);
6448 rhs = gfc_copy_expr (code->expr1);
6449 gfc_add_vptr_component (rhs);
6451 /* Make sure that the component backend_decls have been built, which
6452 will not have happened if the derived types concerned have not
6454 gfc_get_derived_type (rhs->ts.u.derived);
6455 gfc_add_def_init_component (rhs);
6457 sz = gfc_copy_expr (code->expr1);
6458 gfc_add_vptr_component (sz);
6459 gfc_add_size_component (sz);
6461 gfc_init_se (&dst, NULL);
6462 gfc_init_se (&src, NULL);
6463 gfc_init_se (&memsz, NULL);
6464 gfc_conv_expr (&dst, lhs);
6465 gfc_conv_expr (&src, rhs);
6466 gfc_conv_expr (&memsz, sz);
6467 gfc_add_block_to_block (&block, &src.pre);
6468 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6469 gfc_add_expr_to_block (&block, tmp);
6471 return gfc_finish_block (&block);
6475 /* Translate an assignment to a CLASS object
6476 (pointer or ordinary assignment). */
6479 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6486 gfc_start_block (&block);
6488 if (expr2->ts.type != BT_CLASS)
6490 /* Insert an additional assignment which sets the '_vptr' field. */
6491 gfc_symbol *vtab = NULL;
6494 lhs = gfc_copy_expr (expr1);
6495 gfc_add_vptr_component (lhs);
6497 if (expr2->ts.type == BT_DERIVED)
6498 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6499 else if (expr2->expr_type == EXPR_NULL)
6500 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6503 rhs = gfc_get_expr ();
6504 rhs->expr_type = EXPR_VARIABLE;
6505 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6509 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6510 gfc_add_expr_to_block (&block, tmp);
6512 gfc_free_expr (lhs);
6513 gfc_free_expr (rhs);
6516 /* Do the actual CLASS assignment. */
6517 if (expr2->ts.type == BT_CLASS)
6520 gfc_add_data_component (expr1);
6522 if (op == EXEC_ASSIGN)
6523 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6524 else if (op == EXEC_POINTER_ASSIGN)
6525 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6529 gfc_add_expr_to_block (&block, tmp);
6531 return gfc_finish_block (&block);