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)
2362 gfc_array_info *info;
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 = rse.ss->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;
2857 gfc_array_info *info;
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 (se->ss->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, se->ss,
3606 tmp, NULL_TREE, false,
3607 !comp->attr.pointer,
3608 callee_alloc, &se->ss->expr->where);
3610 /* Pass the temporary as the first argument. */
3611 result = info->descriptor;
3612 tmp = gfc_build_addr_expr (NULL_TREE, result);
3613 VEC_safe_push (tree, gc, retargs, tmp);
3615 else if (!comp && sym->result->attr.dimension)
3617 gcc_assert (se->loop && info);
3619 /* Set the type of the array. */
3620 tmp = gfc_typenode_for_spec (&ts);
3621 gcc_assert (se->ss->dimen == se->loop->dimen);
3623 /* Evaluate the bounds of the result, if known. */
3624 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3626 /* If the lhs of an assignment x = f(..) is allocatable and
3627 f2003 is allowed, we must not generate the function call
3628 here but should just send back the results of the mapping.
3629 This is signalled by the function ss being flagged. */
3630 if (gfc_option.flag_realloc_lhs
3631 && se->ss && se->ss->is_alloc_lhs)
3633 gfc_free_interface_mapping (&mapping);
3634 return has_alternate_specifier;
3637 /* Create a temporary to store the result. In case the function
3638 returns a pointer, the temporary will be a shallow copy and
3639 mustn't be deallocated. */
3640 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3641 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
3642 tmp, NULL_TREE, false,
3644 callee_alloc, &se->ss->expr->where);
3646 /* Pass the temporary as the first argument. */
3647 result = info->descriptor;
3648 tmp = gfc_build_addr_expr (NULL_TREE, result);
3649 VEC_safe_push (tree, gc, retargs, tmp);
3651 else if (ts.type == BT_CHARACTER)
3653 /* Pass the string length. */
3654 type = gfc_get_character_type (ts.kind, ts.u.cl);
3655 type = build_pointer_type (type);
3657 /* Return an address to a char[0:len-1]* temporary for
3658 character pointers. */
3659 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3660 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3662 var = gfc_create_var (type, "pstr");
3664 if ((!comp && sym->attr.allocatable)
3665 || (comp && comp->attr.allocatable))
3666 gfc_add_modify (&se->pre, var,
3667 fold_convert (TREE_TYPE (var),
3668 null_pointer_node));
3670 /* Provide an address expression for the function arguments. */
3671 var = gfc_build_addr_expr (NULL_TREE, var);
3674 var = gfc_conv_string_tmp (se, type, len);
3676 VEC_safe_push (tree, gc, retargs, var);
3680 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3682 type = gfc_get_complex_type (ts.kind);
3683 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3684 VEC_safe_push (tree, gc, retargs, var);
3687 if (ts.type == BT_CHARACTER && ts.deferred
3688 && (sym->attr.allocatable || sym->attr.pointer))
3691 if (TREE_CODE (tmp) != VAR_DECL)
3692 tmp = gfc_evaluate_now (len, &se->pre);
3693 len = gfc_build_addr_expr (NULL_TREE, tmp);
3696 /* Add the string length to the argument list. */
3697 if (ts.type == BT_CHARACTER)
3698 VEC_safe_push (tree, gc, retargs, len);
3700 gfc_free_interface_mapping (&mapping);
3702 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3703 arglen = (VEC_length (tree, arglist)
3704 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3705 VEC_reserve_exact (tree, gc, retargs, arglen);
3707 /* Add the return arguments. */
3708 VEC_splice (tree, retargs, arglist);
3710 /* Add the hidden string length parameters to the arguments. */
3711 VEC_splice (tree, retargs, stringargs);
3713 /* We may want to append extra arguments here. This is used e.g. for
3714 calls to libgfortran_matmul_??, which need extra information. */
3715 if (!VEC_empty (tree, append_args))
3716 VEC_splice (tree, retargs, append_args);
3719 /* Generate the actual call. */
3720 conv_function_val (se, sym, expr);
3722 /* If there are alternate return labels, function type should be
3723 integer. Can't modify the type in place though, since it can be shared
3724 with other functions. For dummy arguments, the typing is done to
3725 this result, even if it has to be repeated for each call. */
3726 if (has_alternate_specifier
3727 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3729 if (!sym->attr.dummy)
3731 TREE_TYPE (sym->backend_decl)
3732 = build_function_type (integer_type_node,
3733 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3734 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3737 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3740 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3741 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3743 /* If we have a pointer function, but we don't want a pointer, e.g.
3746 where f is pointer valued, we have to dereference the result. */
3747 if (!se->want_pointer && !byref
3748 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3749 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3750 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3752 /* f2c calling conventions require a scalar default real function to
3753 return a double precision result. Convert this back to default
3754 real. We only care about the cases that can happen in Fortran 77.
3756 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3757 && sym->ts.kind == gfc_default_real_kind
3758 && !sym->attr.always_explicit)
3759 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3761 /* A pure function may still have side-effects - it may modify its
3763 TREE_SIDE_EFFECTS (se->expr) = 1;
3765 if (!sym->attr.pure)
3766 TREE_SIDE_EFFECTS (se->expr) = 1;
3771 /* Add the function call to the pre chain. There is no expression. */
3772 gfc_add_expr_to_block (&se->pre, se->expr);
3773 se->expr = NULL_TREE;
3775 if (!se->direct_byref)
3777 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3779 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3781 /* Check the data pointer hasn't been modified. This would
3782 happen in a function returning a pointer. */
3783 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3784 tmp = fold_build2_loc (input_location, NE_EXPR,
3787 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3790 se->expr = info->descriptor;
3791 /* Bundle in the string length. */
3792 se->string_length = len;
3794 else if (ts.type == BT_CHARACTER)
3796 /* Dereference for character pointer results. */
3797 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3798 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3799 se->expr = build_fold_indirect_ref_loc (input_location, var);
3804 se->string_length = len;
3805 else if (sym->attr.allocatable || sym->attr.pointer)
3806 se->string_length = cl.backend_decl;
3810 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3811 se->expr = build_fold_indirect_ref_loc (input_location, var);
3816 /* Follow the function call with the argument post block. */
3819 gfc_add_block_to_block (&se->pre, &post);
3821 /* Transformational functions of derived types with allocatable
3822 components must have the result allocatable components copied. */
3823 arg = expr->value.function.actual;
3824 if (result && arg && expr->rank
3825 && expr->value.function.isym
3826 && expr->value.function.isym->transformational
3827 && arg->expr->ts.type == BT_DERIVED
3828 && arg->expr->ts.u.derived->attr.alloc_comp)
3831 /* Copy the allocatable components. We have to use a
3832 temporary here to prevent source allocatable components
3833 from being corrupted. */
3834 tmp2 = gfc_evaluate_now (result, &se->pre);
3835 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3836 result, tmp2, expr->rank);
3837 gfc_add_expr_to_block (&se->pre, tmp);
3838 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3840 gfc_add_expr_to_block (&se->pre, tmp);
3842 /* Finally free the temporary's data field. */
3843 tmp = gfc_conv_descriptor_data_get (tmp2);
3844 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3845 gfc_add_expr_to_block (&se->pre, tmp);
3849 gfc_add_block_to_block (&se->post, &post);
3851 return has_alternate_specifier;
3855 /* Fill a character string with spaces. */
3858 fill_with_spaces (tree start, tree type, tree size)
3860 stmtblock_t block, loop;
3861 tree i, el, exit_label, cond, tmp;
3863 /* For a simple char type, we can call memset(). */
3864 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3865 return build_call_expr_loc (input_location,
3866 builtin_decl_explicit (BUILT_IN_MEMSET),
3868 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3869 lang_hooks.to_target_charset (' ')),
3872 /* Otherwise, we use a loop:
3873 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3877 /* Initialize variables. */
3878 gfc_init_block (&block);
3879 i = gfc_create_var (sizetype, "i");
3880 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3881 el = gfc_create_var (build_pointer_type (type), "el");
3882 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3883 exit_label = gfc_build_label_decl (NULL_TREE);
3884 TREE_USED (exit_label) = 1;
3888 gfc_init_block (&loop);
3890 /* Exit condition. */
3891 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3892 build_zero_cst (sizetype));
3893 tmp = build1_v (GOTO_EXPR, exit_label);
3894 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3895 build_empty_stmt (input_location));
3896 gfc_add_expr_to_block (&loop, tmp);
3899 gfc_add_modify (&loop,
3900 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3901 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3903 /* Increment loop variables. */
3904 gfc_add_modify (&loop, i,
3905 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3906 TYPE_SIZE_UNIT (type)));
3907 gfc_add_modify (&loop, el,
3908 fold_build_pointer_plus_loc (input_location,
3909 el, TYPE_SIZE_UNIT (type)));
3911 /* Making the loop... actually loop! */
3912 tmp = gfc_finish_block (&loop);
3913 tmp = build1_v (LOOP_EXPR, tmp);
3914 gfc_add_expr_to_block (&block, tmp);
3916 /* The exit label. */
3917 tmp = build1_v (LABEL_EXPR, exit_label);
3918 gfc_add_expr_to_block (&block, tmp);
3921 return gfc_finish_block (&block);
3925 /* Generate code to copy a string. */
3928 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3929 int dkind, tree slength, tree src, int skind)
3931 tree tmp, dlen, slen;
3940 stmtblock_t tempblock;
3942 gcc_assert (dkind == skind);
3944 if (slength != NULL_TREE)
3946 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3947 ssc = gfc_string_to_single_character (slen, src, skind);
3951 slen = build_int_cst (size_type_node, 1);
3955 if (dlength != NULL_TREE)
3957 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3958 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3962 dlen = build_int_cst (size_type_node, 1);
3966 /* Assign directly if the types are compatible. */
3967 if (dsc != NULL_TREE && ssc != NULL_TREE
3968 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3970 gfc_add_modify (block, dsc, ssc);
3974 /* Do nothing if the destination length is zero. */
3975 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3976 build_int_cst (size_type_node, 0));
3978 /* The following code was previously in _gfortran_copy_string:
3980 // The two strings may overlap so we use memmove.
3982 copy_string (GFC_INTEGER_4 destlen, char * dest,
3983 GFC_INTEGER_4 srclen, const char * src)
3985 if (srclen >= destlen)
3987 // This will truncate if too long.
3988 memmove (dest, src, destlen);
3992 memmove (dest, src, srclen);
3994 memset (&dest[srclen], ' ', destlen - srclen);
3998 We're now doing it here for better optimization, but the logic
4001 /* For non-default character kinds, we have to multiply the string
4002 length by the base type size. */
4003 chartype = gfc_get_char_type (dkind);
4004 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4005 fold_convert (size_type_node, slen),
4006 fold_convert (size_type_node,
4007 TYPE_SIZE_UNIT (chartype)));
4008 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4009 fold_convert (size_type_node, dlen),
4010 fold_convert (size_type_node,
4011 TYPE_SIZE_UNIT (chartype)));
4013 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4014 dest = fold_convert (pvoid_type_node, dest);
4016 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4018 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4019 src = fold_convert (pvoid_type_node, src);
4021 src = gfc_build_addr_expr (pvoid_type_node, src);
4023 /* Truncate string if source is too long. */
4024 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4026 tmp2 = build_call_expr_loc (input_location,
4027 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4028 3, dest, src, dlen);
4030 /* Else copy and pad with spaces. */
4031 tmp3 = build_call_expr_loc (input_location,
4032 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4033 3, dest, src, slen);
4035 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4036 tmp4 = fill_with_spaces (tmp4, chartype,
4037 fold_build2_loc (input_location, MINUS_EXPR,
4038 TREE_TYPE(dlen), dlen, slen));
4040 gfc_init_block (&tempblock);
4041 gfc_add_expr_to_block (&tempblock, tmp3);
4042 gfc_add_expr_to_block (&tempblock, tmp4);
4043 tmp3 = gfc_finish_block (&tempblock);
4045 /* The whole copy_string function is there. */
4046 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4048 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4049 build_empty_stmt (input_location));
4050 gfc_add_expr_to_block (block, tmp);
4054 /* Translate a statement function.
4055 The value of a statement function reference is obtained by evaluating the
4056 expression using the values of the actual arguments for the values of the
4057 corresponding dummy arguments. */
4060 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4064 gfc_formal_arglist *fargs;
4065 gfc_actual_arglist *args;
4068 gfc_saved_var *saved_vars;
4074 sym = expr->symtree->n.sym;
4075 args = expr->value.function.actual;
4076 gfc_init_se (&lse, NULL);
4077 gfc_init_se (&rse, NULL);
4080 for (fargs = sym->formal; fargs; fargs = fargs->next)
4082 saved_vars = XCNEWVEC (gfc_saved_var, n);
4083 temp_vars = XCNEWVEC (tree, n);
4085 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4087 /* Each dummy shall be specified, explicitly or implicitly, to be
4089 gcc_assert (fargs->sym->attr.dimension == 0);
4092 if (fsym->ts.type == BT_CHARACTER)
4094 /* Copy string arguments. */
4097 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4098 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4100 /* Create a temporary to hold the value. */
4101 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4102 fsym->ts.u.cl->backend_decl
4103 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4105 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4106 temp_vars[n] = gfc_create_var (type, fsym->name);
4108 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4110 gfc_conv_expr (&rse, args->expr);
4111 gfc_conv_string_parameter (&rse);
4112 gfc_add_block_to_block (&se->pre, &lse.pre);
4113 gfc_add_block_to_block (&se->pre, &rse.pre);
4115 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4116 rse.string_length, rse.expr, fsym->ts.kind);
4117 gfc_add_block_to_block (&se->pre, &lse.post);
4118 gfc_add_block_to_block (&se->pre, &rse.post);
4122 /* For everything else, just evaluate the expression. */
4124 /* Create a temporary to hold the value. */
4125 type = gfc_typenode_for_spec (&fsym->ts);
4126 temp_vars[n] = gfc_create_var (type, fsym->name);
4128 gfc_conv_expr (&lse, args->expr);
4130 gfc_add_block_to_block (&se->pre, &lse.pre);
4131 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4132 gfc_add_block_to_block (&se->pre, &lse.post);
4138 /* Use the temporary variables in place of the real ones. */
4139 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4140 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4142 gfc_conv_expr (se, sym->value);
4144 if (sym->ts.type == BT_CHARACTER)
4146 gfc_conv_const_charlen (sym->ts.u.cl);
4148 /* Force the expression to the correct length. */
4149 if (!INTEGER_CST_P (se->string_length)
4150 || tree_int_cst_lt (se->string_length,
4151 sym->ts.u.cl->backend_decl))
4153 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4154 tmp = gfc_create_var (type, sym->name);
4155 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4156 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4157 sym->ts.kind, se->string_length, se->expr,
4161 se->string_length = sym->ts.u.cl->backend_decl;
4164 /* Restore the original variables. */
4165 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4166 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4171 /* Translate a function expression. */
4174 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4178 if (expr->value.function.isym)
4180 gfc_conv_intrinsic_function (se, expr);
4184 /* We distinguish statement functions from general functions to improve
4185 runtime performance. */
4186 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4188 gfc_conv_statement_function (se, expr);
4192 /* expr.value.function.esym is the resolved (specific) function symbol for
4193 most functions. However this isn't set for dummy procedures. */
4194 sym = expr->value.function.esym;
4196 sym = expr->symtree->n.sym;
4198 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4202 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4205 is_zero_initializer_p (gfc_expr * expr)
4207 if (expr->expr_type != EXPR_CONSTANT)
4210 /* We ignore constants with prescribed memory representations for now. */
4211 if (expr->representation.string)
4214 switch (expr->ts.type)
4217 return mpz_cmp_si (expr->value.integer, 0) == 0;
4220 return mpfr_zero_p (expr->value.real)
4221 && MPFR_SIGN (expr->value.real) >= 0;
4224 return expr->value.logical == 0;
4227 return mpfr_zero_p (mpc_realref (expr->value.complex))
4228 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4229 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4230 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4240 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4242 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4243 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4245 gfc_conv_tmp_array_ref (se);
4249 /* Build a static initializer. EXPR is the expression for the initial value.
4250 The other parameters describe the variable of the component being
4251 initialized. EXPR may be null. */
4254 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4255 bool array, bool pointer, bool procptr)
4259 if (!(expr || pointer || procptr))
4262 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4263 (these are the only two iso_c_binding derived types that can be
4264 used as initialization expressions). If so, we need to modify
4265 the 'expr' to be that for a (void *). */
4266 if (expr != NULL && expr->ts.type == BT_DERIVED
4267 && expr->ts.is_iso_c && expr->ts.u.derived)
4269 gfc_symbol *derived = expr->ts.u.derived;
4271 /* The derived symbol has already been converted to a (void *). Use
4273 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4274 expr->ts.f90_type = derived->ts.f90_type;
4276 gfc_init_se (&se, NULL);
4277 gfc_conv_constant (&se, expr);
4278 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4282 if (array && !procptr)
4285 /* Arrays need special handling. */
4287 ctor = gfc_build_null_descriptor (type);
4288 /* Special case assigning an array to zero. */
4289 else if (is_zero_initializer_p (expr))
4290 ctor = build_constructor (type, NULL);
4292 ctor = gfc_conv_array_initializer (type, expr);
4293 TREE_STATIC (ctor) = 1;
4296 else if (pointer || procptr)
4298 if (!expr || expr->expr_type == EXPR_NULL)
4299 return fold_convert (type, null_pointer_node);
4302 gfc_init_se (&se, NULL);
4303 se.want_pointer = 1;
4304 gfc_conv_expr (&se, expr);
4305 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4315 gfc_init_se (&se, NULL);
4316 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4317 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4319 gfc_conv_structure (&se, expr, 1);
4320 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4321 TREE_STATIC (se.expr) = 1;
4326 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4327 TREE_STATIC (ctor) = 1;
4332 gfc_init_se (&se, NULL);
4333 gfc_conv_constant (&se, expr);
4334 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4341 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4353 gfc_start_block (&block);
4355 /* Initialize the scalarizer. */
4356 gfc_init_loopinfo (&loop);
4358 gfc_init_se (&lse, NULL);
4359 gfc_init_se (&rse, NULL);
4362 rss = gfc_walk_expr (expr);
4363 if (rss == gfc_ss_terminator)
4364 /* The rhs is scalar. Add a ss for the expression. */
4365 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4367 /* Create a SS for the destination. */
4368 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4370 lss->shape = gfc_get_shape (cm->as->rank);
4371 lss->data.info.descriptor = dest;
4372 lss->data.info.data = gfc_conv_array_data (dest);
4373 lss->data.info.offset = gfc_conv_array_offset (dest);
4374 for (n = 0; n < cm->as->rank; n++)
4376 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4377 lss->data.info.stride[n] = gfc_index_one_node;
4379 mpz_init (lss->shape[n]);
4380 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4381 cm->as->lower[n]->value.integer);
4382 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4385 /* Associate the SS with the loop. */
4386 gfc_add_ss_to_loop (&loop, lss);
4387 gfc_add_ss_to_loop (&loop, rss);
4389 /* Calculate the bounds of the scalarization. */
4390 gfc_conv_ss_startstride (&loop);
4392 /* Setup the scalarizing loops. */
4393 gfc_conv_loop_setup (&loop, &expr->where);
4395 /* Setup the gfc_se structures. */
4396 gfc_copy_loopinfo_to_se (&lse, &loop);
4397 gfc_copy_loopinfo_to_se (&rse, &loop);
4400 gfc_mark_ss_chain_used (rss, 1);
4402 gfc_mark_ss_chain_used (lss, 1);
4404 /* Start the scalarized loop body. */
4405 gfc_start_scalarized_body (&loop, &body);
4407 gfc_conv_tmp_array_ref (&lse);
4408 if (cm->ts.type == BT_CHARACTER)
4409 lse.string_length = cm->ts.u.cl->backend_decl;
4411 gfc_conv_expr (&rse, expr);
4413 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4414 gfc_add_expr_to_block (&body, tmp);
4416 gcc_assert (rse.ss == gfc_ss_terminator);
4418 /* Generate the copying loops. */
4419 gfc_trans_scalarizing_loops (&loop, &body);
4421 /* Wrap the whole thing up. */
4422 gfc_add_block_to_block (&block, &loop.pre);
4423 gfc_add_block_to_block (&block, &loop.post);
4425 gcc_assert (lss->shape != NULL);
4426 gfc_free_shape (&lss->shape, cm->as->rank);
4427 gfc_cleanup_loop (&loop);
4429 return gfc_finish_block (&block);
4434 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4445 gfc_expr *arg = NULL;
4447 gfc_start_block (&block);
4448 gfc_init_se (&se, NULL);
4450 /* Get the descriptor for the expressions. */
4451 rss = gfc_walk_expr (expr);
4452 se.want_pointer = 0;
4453 gfc_conv_expr_descriptor (&se, expr, rss);
4454 gfc_add_block_to_block (&block, &se.pre);
4455 gfc_add_modify (&block, dest, se.expr);
4457 /* Deal with arrays of derived types with allocatable components. */
4458 if (cm->ts.type == BT_DERIVED
4459 && cm->ts.u.derived->attr.alloc_comp)
4460 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4464 tmp = gfc_duplicate_allocatable (dest, se.expr,
4465 TREE_TYPE(cm->backend_decl),
4468 gfc_add_expr_to_block (&block, tmp);
4469 gfc_add_block_to_block (&block, &se.post);
4471 if (expr->expr_type != EXPR_VARIABLE)
4472 gfc_conv_descriptor_data_set (&block, se.expr,
4475 /* We need to know if the argument of a conversion function is a
4476 variable, so that the correct lower bound can be used. */
4477 if (expr->expr_type == EXPR_FUNCTION
4478 && expr->value.function.isym
4479 && expr->value.function.isym->conversion
4480 && expr->value.function.actual->expr
4481 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4482 arg = expr->value.function.actual->expr;
4484 /* Obtain the array spec of full array references. */
4486 as = gfc_get_full_arrayspec_from_expr (arg);
4488 as = gfc_get_full_arrayspec_from_expr (expr);
4490 /* Shift the lbound and ubound of temporaries to being unity,
4491 rather than zero, based. Always calculate the offset. */
4492 offset = gfc_conv_descriptor_offset_get (dest);
4493 gfc_add_modify (&block, offset, gfc_index_zero_node);
4494 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4496 for (n = 0; n < expr->rank; n++)
4501 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4502 TODO It looks as if gfc_conv_expr_descriptor should return
4503 the correct bounds and that the following should not be
4504 necessary. This would simplify gfc_conv_intrinsic_bound
4506 if (as && as->lower[n])
4509 gfc_init_se (&lbse, NULL);
4510 gfc_conv_expr (&lbse, as->lower[n]);
4511 gfc_add_block_to_block (&block, &lbse.pre);
4512 lbound = gfc_evaluate_now (lbse.expr, &block);
4516 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4517 lbound = gfc_conv_descriptor_lbound_get (tmp,
4521 lbound = gfc_conv_descriptor_lbound_get (dest,
4524 lbound = gfc_index_one_node;
4526 lbound = fold_convert (gfc_array_index_type, lbound);
4528 /* Shift the bounds and set the offset accordingly. */
4529 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4530 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4531 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4532 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4534 gfc_conv_descriptor_ubound_set (&block, dest,
4535 gfc_rank_cst[n], tmp);
4536 gfc_conv_descriptor_lbound_set (&block, dest,
4537 gfc_rank_cst[n], lbound);
4539 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4540 gfc_conv_descriptor_lbound_get (dest,
4542 gfc_conv_descriptor_stride_get (dest,
4544 gfc_add_modify (&block, tmp2, tmp);
4545 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4547 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4552 /* If a conversion expression has a null data pointer
4553 argument, nullify the allocatable component. */
4557 if (arg->symtree->n.sym->attr.allocatable
4558 || arg->symtree->n.sym->attr.pointer)
4560 non_null_expr = gfc_finish_block (&block);
4561 gfc_start_block (&block);
4562 gfc_conv_descriptor_data_set (&block, dest,
4564 null_expr = gfc_finish_block (&block);
4565 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4566 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4567 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4568 return build3_v (COND_EXPR, tmp,
4569 null_expr, non_null_expr);
4573 return gfc_finish_block (&block);
4577 /* Assign a single component of a derived type constructor. */
4580 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4588 gfc_start_block (&block);
4590 if (cm->attr.pointer)
4592 gfc_init_se (&se, NULL);
4593 /* Pointer component. */
4594 if (cm->attr.dimension)
4596 /* Array pointer. */
4597 if (expr->expr_type == EXPR_NULL)
4598 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4601 rss = gfc_walk_expr (expr);
4602 se.direct_byref = 1;
4604 gfc_conv_expr_descriptor (&se, expr, rss);
4605 gfc_add_block_to_block (&block, &se.pre);
4606 gfc_add_block_to_block (&block, &se.post);
4611 /* Scalar pointers. */
4612 se.want_pointer = 1;
4613 gfc_conv_expr (&se, expr);
4614 gfc_add_block_to_block (&block, &se.pre);
4615 gfc_add_modify (&block, dest,
4616 fold_convert (TREE_TYPE (dest), se.expr));
4617 gfc_add_block_to_block (&block, &se.post);
4620 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4622 /* NULL initialization for CLASS components. */
4623 tmp = gfc_trans_structure_assign (dest,
4624 gfc_class_null_initializer (&cm->ts));
4625 gfc_add_expr_to_block (&block, tmp);
4627 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4629 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4630 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4631 else if (cm->attr.allocatable)
4633 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4634 gfc_add_expr_to_block (&block, tmp);
4638 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4639 gfc_add_expr_to_block (&block, tmp);
4642 else if (expr->ts.type == BT_DERIVED)
4644 if (expr->expr_type != EXPR_STRUCTURE)
4646 gfc_init_se (&se, NULL);
4647 gfc_conv_expr (&se, expr);
4648 gfc_add_block_to_block (&block, &se.pre);
4649 gfc_add_modify (&block, dest,
4650 fold_convert (TREE_TYPE (dest), se.expr));
4651 gfc_add_block_to_block (&block, &se.post);
4655 /* Nested constructors. */
4656 tmp = gfc_trans_structure_assign (dest, expr);
4657 gfc_add_expr_to_block (&block, tmp);
4662 /* Scalar component. */
4663 gfc_init_se (&se, NULL);
4664 gfc_init_se (&lse, NULL);
4666 gfc_conv_expr (&se, expr);
4667 if (cm->ts.type == BT_CHARACTER)
4668 lse.string_length = cm->ts.u.cl->backend_decl;
4670 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4671 gfc_add_expr_to_block (&block, tmp);
4673 return gfc_finish_block (&block);
4676 /* Assign a derived type constructor to a variable. */
4679 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4687 gfc_start_block (&block);
4688 cm = expr->ts.u.derived->components;
4690 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4691 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4692 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4696 gcc_assert (cm->backend_decl == NULL);
4697 gfc_init_se (&se, NULL);
4698 gfc_init_se (&lse, NULL);
4699 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4701 gfc_add_modify (&block, lse.expr,
4702 fold_convert (TREE_TYPE (lse.expr), se.expr));
4704 return gfc_finish_block (&block);
4707 for (c = gfc_constructor_first (expr->value.constructor);
4708 c; c = gfc_constructor_next (c), cm = cm->next)
4710 /* Skip absent members in default initializers. */
4714 field = cm->backend_decl;
4715 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4716 dest, field, NULL_TREE);
4717 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4718 gfc_add_expr_to_block (&block, tmp);
4720 return gfc_finish_block (&block);
4723 /* Build an expression for a constructor. If init is nonzero then
4724 this is part of a static variable initializer. */
4727 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4734 VEC(constructor_elt,gc) *v = NULL;
4736 gcc_assert (se->ss == NULL);
4737 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4738 type = gfc_typenode_for_spec (&expr->ts);
4742 /* Create a temporary variable and fill it in. */
4743 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4744 tmp = gfc_trans_structure_assign (se->expr, expr);
4745 gfc_add_expr_to_block (&se->pre, tmp);
4749 cm = expr->ts.u.derived->components;
4751 for (c = gfc_constructor_first (expr->value.constructor);
4752 c; c = gfc_constructor_next (c), cm = cm->next)
4754 /* Skip absent members in default initializers and allocatable
4755 components. Although the latter have a default initializer
4756 of EXPR_NULL,... by default, the static nullify is not needed
4757 since this is done every time we come into scope. */
4758 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4761 if (strcmp (cm->name, "_size") == 0)
4763 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4764 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4766 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4767 && strcmp (cm->name, "_extends") == 0)
4771 vtabs = cm->initializer->symtree->n.sym;
4772 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4773 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4777 val = gfc_conv_initializer (c->expr, &cm->ts,
4778 TREE_TYPE (cm->backend_decl),
4779 cm->attr.dimension, cm->attr.pointer,
4780 cm->attr.proc_pointer);
4782 /* Append it to the constructor list. */
4783 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4786 se->expr = build_constructor (type, v);
4788 TREE_CONSTANT (se->expr) = 1;
4792 /* Translate a substring expression. */
4795 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4801 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4803 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4804 expr->value.character.length,
4805 expr->value.character.string);
4807 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4808 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4811 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4815 /* Entry point for expression translation. Evaluates a scalar quantity.
4816 EXPR is the expression to be translated, and SE is the state structure if
4817 called from within the scalarized. */
4820 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4822 if (se->ss && se->ss->expr == expr
4823 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4825 /* Substitute a scalar expression evaluated outside the scalarization
4827 se->expr = se->ss->data.scalar.expr;
4828 if (se->ss->type == GFC_SS_REFERENCE)
4829 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4830 se->string_length = se->ss->string_length;
4831 gfc_advance_se_ss_chain (se);
4835 /* We need to convert the expressions for the iso_c_binding derived types.
4836 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4837 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4838 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4839 updated to be an integer with a kind equal to the size of a (void *). */
4840 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4841 && expr->ts.u.derived->attr.is_iso_c)
4843 if (expr->expr_type == EXPR_VARIABLE
4844 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4845 || expr->symtree->n.sym->intmod_sym_id
4846 == ISOCBINDING_NULL_FUNPTR))
4848 /* Set expr_type to EXPR_NULL, which will result in
4849 null_pointer_node being used below. */
4850 expr->expr_type = EXPR_NULL;
4854 /* Update the type/kind of the expression to be what the new
4855 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4856 expr->ts.type = expr->ts.u.derived->ts.type;
4857 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4858 expr->ts.kind = expr->ts.u.derived->ts.kind;
4862 switch (expr->expr_type)
4865 gfc_conv_expr_op (se, expr);
4869 gfc_conv_function_expr (se, expr);
4873 gfc_conv_constant (se, expr);
4877 gfc_conv_variable (se, expr);
4881 se->expr = null_pointer_node;
4884 case EXPR_SUBSTRING:
4885 gfc_conv_substring_expr (se, expr);
4888 case EXPR_STRUCTURE:
4889 gfc_conv_structure (se, expr, 0);
4893 gfc_conv_array_constructor_expr (se, expr);
4902 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4903 of an assignment. */
4905 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4907 gfc_conv_expr (se, expr);
4908 /* All numeric lvalues should have empty post chains. If not we need to
4909 figure out a way of rewriting an lvalue so that it has no post chain. */
4910 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4913 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4914 numeric expressions. Used for scalar values where inserting cleanup code
4917 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4921 gcc_assert (expr->ts.type != BT_CHARACTER);
4922 gfc_conv_expr (se, expr);
4925 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4926 gfc_add_modify (&se->pre, val, se->expr);
4928 gfc_add_block_to_block (&se->pre, &se->post);
4932 /* Helper to translate an expression and convert it to a particular type. */
4934 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4936 gfc_conv_expr_val (se, expr);
4937 se->expr = convert (type, se->expr);
4941 /* Converts an expression so that it can be passed by reference. Scalar
4945 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4949 if (se->ss && se->ss->expr == expr
4950 && se->ss->type == GFC_SS_REFERENCE)
4952 /* Returns a reference to the scalar evaluated outside the loop
4954 gfc_conv_expr (se, expr);
4958 if (expr->ts.type == BT_CHARACTER)
4960 gfc_conv_expr (se, expr);
4961 gfc_conv_string_parameter (se);
4965 if (expr->expr_type == EXPR_VARIABLE)
4967 se->want_pointer = 1;
4968 gfc_conv_expr (se, expr);
4971 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4972 gfc_add_modify (&se->pre, var, se->expr);
4973 gfc_add_block_to_block (&se->pre, &se->post);
4979 if (expr->expr_type == EXPR_FUNCTION
4980 && ((expr->value.function.esym
4981 && expr->value.function.esym->result->attr.pointer
4982 && !expr->value.function.esym->result->attr.dimension)
4983 || (!expr->value.function.esym
4984 && expr->symtree->n.sym->attr.pointer
4985 && !expr->symtree->n.sym->attr.dimension)))
4987 se->want_pointer = 1;
4988 gfc_conv_expr (se, expr);
4989 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4990 gfc_add_modify (&se->pre, var, se->expr);
4996 gfc_conv_expr (se, expr);
4998 /* Create a temporary var to hold the value. */
4999 if (TREE_CONSTANT (se->expr))
5001 tree tmp = se->expr;
5002 STRIP_TYPE_NOPS (tmp);
5003 var = build_decl (input_location,
5004 CONST_DECL, NULL, TREE_TYPE (tmp));
5005 DECL_INITIAL (var) = tmp;
5006 TREE_STATIC (var) = 1;
5011 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5012 gfc_add_modify (&se->pre, var, se->expr);
5014 gfc_add_block_to_block (&se->pre, &se->post);
5016 /* Take the address of that value. */
5017 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5022 gfc_trans_pointer_assign (gfc_code * code)
5024 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5028 /* Generate code for a pointer assignment. */
5031 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5042 gfc_start_block (&block);
5044 gfc_init_se (&lse, NULL);
5046 lss = gfc_walk_expr (expr1);
5047 rss = gfc_walk_expr (expr2);
5048 if (lss == gfc_ss_terminator)
5050 /* Scalar pointers. */
5051 lse.want_pointer = 1;
5052 gfc_conv_expr (&lse, expr1);
5053 gcc_assert (rss == gfc_ss_terminator);
5054 gfc_init_se (&rse, NULL);
5055 rse.want_pointer = 1;
5056 gfc_conv_expr (&rse, expr2);
5058 if (expr1->symtree->n.sym->attr.proc_pointer
5059 && expr1->symtree->n.sym->attr.dummy)
5060 lse.expr = build_fold_indirect_ref_loc (input_location,
5063 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5064 && expr2->symtree->n.sym->attr.dummy)
5065 rse.expr = build_fold_indirect_ref_loc (input_location,
5068 gfc_add_block_to_block (&block, &lse.pre);
5069 gfc_add_block_to_block (&block, &rse.pre);
5071 /* Check character lengths if character expression. The test is only
5072 really added if -fbounds-check is enabled. Exclude deferred
5073 character length lefthand sides. */
5074 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5075 && !(expr1->ts.deferred
5076 && (TREE_CODE (lse.string_length) == VAR_DECL))
5077 && !expr1->symtree->n.sym->attr.proc_pointer
5078 && !gfc_is_proc_ptr_comp (expr1, NULL))
5080 gcc_assert (expr2->ts.type == BT_CHARACTER);
5081 gcc_assert (lse.string_length && rse.string_length);
5082 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5083 lse.string_length, rse.string_length,
5087 /* The assignment to an deferred character length sets the string
5088 length to that of the rhs. */
5089 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5091 if (expr2->expr_type != EXPR_NULL)
5092 gfc_add_modify (&block, lse.string_length, rse.string_length);
5094 gfc_add_modify (&block, lse.string_length,
5095 build_int_cst (gfc_charlen_type_node, 0));
5098 gfc_add_modify (&block, lse.expr,
5099 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5101 gfc_add_block_to_block (&block, &rse.post);
5102 gfc_add_block_to_block (&block, &lse.post);
5109 tree strlen_rhs = NULL_TREE;
5111 /* Array pointer. Find the last reference on the LHS and if it is an
5112 array section ref, we're dealing with bounds remapping. In this case,
5113 set it to AR_FULL so that gfc_conv_expr_descriptor does
5114 not see it and process the bounds remapping afterwards explicitely. */
5115 for (remap = expr1->ref; remap; remap = remap->next)
5116 if (!remap->next && remap->type == REF_ARRAY
5117 && remap->u.ar.type == AR_SECTION)
5119 remap->u.ar.type = AR_FULL;
5122 rank_remap = (remap && remap->u.ar.end[0]);
5124 gfc_conv_expr_descriptor (&lse, expr1, lss);
5125 strlen_lhs = lse.string_length;
5128 if (expr2->expr_type == EXPR_NULL)
5130 /* Just set the data pointer to null. */
5131 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5133 else if (rank_remap)
5135 /* If we are rank-remapping, just get the RHS's descriptor and
5136 process this later on. */
5137 gfc_init_se (&rse, NULL);
5138 rse.direct_byref = 1;
5139 rse.byref_noassign = 1;
5140 gfc_conv_expr_descriptor (&rse, expr2, rss);
5141 strlen_rhs = rse.string_length;
5143 else if (expr2->expr_type == EXPR_VARIABLE)
5145 /* Assign directly to the LHS's descriptor. */
5146 lse.direct_byref = 1;
5147 gfc_conv_expr_descriptor (&lse, expr2, rss);
5148 strlen_rhs = lse.string_length;
5150 /* If this is a subreference array pointer assignment, use the rhs
5151 descriptor element size for the lhs span. */
5152 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5154 decl = expr1->symtree->n.sym->backend_decl;
5155 gfc_init_se (&rse, NULL);
5156 rse.descriptor_only = 1;
5157 gfc_conv_expr (&rse, expr2);
5158 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5159 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5160 if (!INTEGER_CST_P (tmp))
5161 gfc_add_block_to_block (&lse.post, &rse.pre);
5162 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5167 /* Assign to a temporary descriptor and then copy that
5168 temporary to the pointer. */
5169 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5172 lse.direct_byref = 1;
5173 gfc_conv_expr_descriptor (&lse, expr2, rss);
5174 strlen_rhs = lse.string_length;
5175 gfc_add_modify (&lse.pre, desc, tmp);
5178 gfc_add_block_to_block (&block, &lse.pre);
5180 gfc_add_block_to_block (&block, &rse.pre);
5182 /* If we do bounds remapping, update LHS descriptor accordingly. */
5186 gcc_assert (remap->u.ar.dimen == expr1->rank);
5190 /* Do rank remapping. We already have the RHS's descriptor
5191 converted in rse and now have to build the correct LHS
5192 descriptor for it. */
5196 tree lbound, ubound;
5199 dtype = gfc_conv_descriptor_dtype (desc);
5200 tmp = gfc_get_dtype (TREE_TYPE (desc));
5201 gfc_add_modify (&block, dtype, tmp);
5203 /* Copy data pointer. */
5204 data = gfc_conv_descriptor_data_get (rse.expr);
5205 gfc_conv_descriptor_data_set (&block, desc, data);
5207 /* Copy offset but adjust it such that it would correspond
5208 to a lbound of zero. */
5209 offs = gfc_conv_descriptor_offset_get (rse.expr);
5210 for (dim = 0; dim < expr2->rank; ++dim)
5212 stride = gfc_conv_descriptor_stride_get (rse.expr,
5214 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5216 tmp = fold_build2_loc (input_location, MULT_EXPR,
5217 gfc_array_index_type, stride, lbound);
5218 offs = fold_build2_loc (input_location, PLUS_EXPR,
5219 gfc_array_index_type, offs, tmp);
5221 gfc_conv_descriptor_offset_set (&block, desc, offs);
5223 /* Set the bounds as declared for the LHS and calculate strides as
5224 well as another offset update accordingly. */
5225 stride = gfc_conv_descriptor_stride_get (rse.expr,
5227 for (dim = 0; dim < expr1->rank; ++dim)
5232 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5234 /* Convert declared bounds. */
5235 gfc_init_se (&lower_se, NULL);
5236 gfc_init_se (&upper_se, NULL);
5237 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5238 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5240 gfc_add_block_to_block (&block, &lower_se.pre);
5241 gfc_add_block_to_block (&block, &upper_se.pre);
5243 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5244 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5246 lbound = gfc_evaluate_now (lbound, &block);
5247 ubound = gfc_evaluate_now (ubound, &block);
5249 gfc_add_block_to_block (&block, &lower_se.post);
5250 gfc_add_block_to_block (&block, &upper_se.post);
5252 /* Set bounds in descriptor. */
5253 gfc_conv_descriptor_lbound_set (&block, desc,
5254 gfc_rank_cst[dim], lbound);
5255 gfc_conv_descriptor_ubound_set (&block, desc,
5256 gfc_rank_cst[dim], ubound);
5259 stride = gfc_evaluate_now (stride, &block);
5260 gfc_conv_descriptor_stride_set (&block, desc,
5261 gfc_rank_cst[dim], stride);
5263 /* Update offset. */
5264 offs = gfc_conv_descriptor_offset_get (desc);
5265 tmp = fold_build2_loc (input_location, MULT_EXPR,
5266 gfc_array_index_type, lbound, stride);
5267 offs = fold_build2_loc (input_location, MINUS_EXPR,
5268 gfc_array_index_type, offs, tmp);
5269 offs = gfc_evaluate_now (offs, &block);
5270 gfc_conv_descriptor_offset_set (&block, desc, offs);
5272 /* Update stride. */
5273 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5274 stride = fold_build2_loc (input_location, MULT_EXPR,
5275 gfc_array_index_type, stride, tmp);
5280 /* Bounds remapping. Just shift the lower bounds. */
5282 gcc_assert (expr1->rank == expr2->rank);
5284 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5288 gcc_assert (remap->u.ar.start[dim]);
5289 gcc_assert (!remap->u.ar.end[dim]);
5290 gfc_init_se (&lbound_se, NULL);
5291 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5293 gfc_add_block_to_block (&block, &lbound_se.pre);
5294 gfc_conv_shift_descriptor_lbound (&block, desc,
5295 dim, lbound_se.expr);
5296 gfc_add_block_to_block (&block, &lbound_se.post);
5301 /* Check string lengths if applicable. The check is only really added
5302 to the output code if -fbounds-check is enabled. */
5303 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5305 gcc_assert (expr2->ts.type == BT_CHARACTER);
5306 gcc_assert (strlen_lhs && strlen_rhs);
5307 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5308 strlen_lhs, strlen_rhs, &block);
5311 /* If rank remapping was done, check with -fcheck=bounds that
5312 the target is at least as large as the pointer. */
5313 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5319 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5320 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5322 lsize = gfc_evaluate_now (lsize, &block);
5323 rsize = gfc_evaluate_now (rsize, &block);
5324 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5327 msg = _("Target of rank remapping is too small (%ld < %ld)");
5328 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5332 gfc_add_block_to_block (&block, &lse.post);
5334 gfc_add_block_to_block (&block, &rse.post);
5337 return gfc_finish_block (&block);
5341 /* Makes sure se is suitable for passing as a function string parameter. */
5342 /* TODO: Need to check all callers of this function. It may be abused. */
5345 gfc_conv_string_parameter (gfc_se * se)
5349 if (TREE_CODE (se->expr) == STRING_CST)
5351 type = TREE_TYPE (TREE_TYPE (se->expr));
5352 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5356 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5358 if (TREE_CODE (se->expr) != INDIRECT_REF)
5360 type = TREE_TYPE (se->expr);
5361 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5365 type = gfc_get_character_type_len (gfc_default_character_kind,
5367 type = build_pointer_type (type);
5368 se->expr = gfc_build_addr_expr (type, se->expr);
5372 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5376 /* Generate code for assignment of scalar variables. Includes character
5377 strings and derived types with allocatable components.
5378 If you know that the LHS has no allocations, set dealloc to false. */
5381 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5382 bool l_is_temp, bool r_is_var, bool dealloc)
5388 gfc_init_block (&block);
5390 if (ts.type == BT_CHARACTER)
5395 if (lse->string_length != NULL_TREE)
5397 gfc_conv_string_parameter (lse);
5398 gfc_add_block_to_block (&block, &lse->pre);
5399 llen = lse->string_length;
5402 if (rse->string_length != NULL_TREE)
5404 gcc_assert (rse->string_length != NULL_TREE);
5405 gfc_conv_string_parameter (rse);
5406 gfc_add_block_to_block (&block, &rse->pre);
5407 rlen = rse->string_length;
5410 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5411 rse->expr, ts.kind);
5413 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5417 /* Are the rhs and the lhs the same? */
5420 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5421 gfc_build_addr_expr (NULL_TREE, lse->expr),
5422 gfc_build_addr_expr (NULL_TREE, rse->expr));
5423 cond = gfc_evaluate_now (cond, &lse->pre);
5426 /* Deallocate the lhs allocated components as long as it is not
5427 the same as the rhs. This must be done following the assignment
5428 to prevent deallocating data that could be used in the rhs
5430 if (!l_is_temp && dealloc)
5432 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5433 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5435 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5437 gfc_add_expr_to_block (&lse->post, tmp);
5440 gfc_add_block_to_block (&block, &rse->pre);
5441 gfc_add_block_to_block (&block, &lse->pre);
5443 gfc_add_modify (&block, lse->expr,
5444 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5446 /* Do a deep copy if the rhs is a variable, if it is not the
5450 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5451 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5453 gfc_add_expr_to_block (&block, tmp);
5456 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5458 gfc_add_block_to_block (&block, &lse->pre);
5459 gfc_add_block_to_block (&block, &rse->pre);
5460 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5461 TREE_TYPE (lse->expr), rse->expr);
5462 gfc_add_modify (&block, lse->expr, tmp);
5466 gfc_add_block_to_block (&block, &lse->pre);
5467 gfc_add_block_to_block (&block, &rse->pre);
5469 gfc_add_modify (&block, lse->expr,
5470 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5473 gfc_add_block_to_block (&block, &lse->post);
5474 gfc_add_block_to_block (&block, &rse->post);
5476 return gfc_finish_block (&block);
5480 /* There are quite a lot of restrictions on the optimisation in using an
5481 array function assign without a temporary. */
5484 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5487 bool seen_array_ref;
5489 gfc_symbol *sym = expr1->symtree->n.sym;
5491 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5492 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5495 /* Elemental functions are scalarized so that they don't need a
5496 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5497 they would need special treatment in gfc_trans_arrayfunc_assign. */
5498 if (expr2->value.function.esym != NULL
5499 && expr2->value.function.esym->attr.elemental)
5502 /* Need a temporary if rhs is not FULL or a contiguous section. */
5503 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5506 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5507 if (gfc_ref_needs_temporary_p (expr1->ref))
5510 /* Functions returning pointers or allocatables need temporaries. */
5511 c = expr2->value.function.esym
5512 ? (expr2->value.function.esym->attr.pointer
5513 || expr2->value.function.esym->attr.allocatable)
5514 : (expr2->symtree->n.sym->attr.pointer
5515 || expr2->symtree->n.sym->attr.allocatable);
5519 /* Character array functions need temporaries unless the
5520 character lengths are the same. */
5521 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5523 if (expr1->ts.u.cl->length == NULL
5524 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5527 if (expr2->ts.u.cl->length == NULL
5528 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5531 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5532 expr2->ts.u.cl->length->value.integer) != 0)
5536 /* Check that no LHS component references appear during an array
5537 reference. This is needed because we do not have the means to
5538 span any arbitrary stride with an array descriptor. This check
5539 is not needed for the rhs because the function result has to be
5541 seen_array_ref = false;
5542 for (ref = expr1->ref; ref; ref = ref->next)
5544 if (ref->type == REF_ARRAY)
5545 seen_array_ref= true;
5546 else if (ref->type == REF_COMPONENT && seen_array_ref)
5550 /* Check for a dependency. */
5551 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5552 expr2->value.function.esym,
5553 expr2->value.function.actual,
5557 /* If we have reached here with an intrinsic function, we do not
5558 need a temporary except in the particular case that reallocation
5559 on assignment is active and the lhs is allocatable and a target. */
5560 if (expr2->value.function.isym)
5561 return (gfc_option.flag_realloc_lhs
5562 && sym->attr.allocatable
5563 && sym->attr.target);
5565 /* If the LHS is a dummy, we need a temporary if it is not
5567 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5570 /* If the lhs has been host_associated, is in common, a pointer or is
5571 a target and the function is not using a RESULT variable, aliasing
5572 can occur and a temporary is needed. */
5573 if ((sym->attr.host_assoc
5574 || sym->attr.in_common
5575 || sym->attr.pointer
5576 || sym->attr.cray_pointee
5577 || sym->attr.target)
5578 && expr2->symtree != NULL
5579 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5582 /* A PURE function can unconditionally be called without a temporary. */
5583 if (expr2->value.function.esym != NULL
5584 && expr2->value.function.esym->attr.pure)
5587 /* Implicit_pure functions are those which could legally be declared
5589 if (expr2->value.function.esym != NULL
5590 && expr2->value.function.esym->attr.implicit_pure)
5593 if (!sym->attr.use_assoc
5594 && !sym->attr.in_common
5595 && !sym->attr.pointer
5596 && !sym->attr.target
5597 && !sym->attr.cray_pointee
5598 && expr2->value.function.esym)
5600 /* A temporary is not needed if the function is not contained and
5601 the variable is local or host associated and not a pointer or
5603 if (!expr2->value.function.esym->attr.contained)
5606 /* A temporary is not needed if the lhs has never been host
5607 associated and the procedure is contained. */
5608 else if (!sym->attr.host_assoc)
5611 /* A temporary is not needed if the variable is local and not
5612 a pointer, a target or a result. */
5614 && expr2->value.function.esym->ns == sym->ns->parent)
5618 /* Default to temporary use. */
5623 /* Provide the loop info so that the lhs descriptor can be built for
5624 reallocatable assignments from extrinsic function calls. */
5627 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5630 /* Signal that the function call should not be made by
5631 gfc_conv_loop_setup. */
5632 se->ss->is_alloc_lhs = 1;
5633 gfc_init_loopinfo (loop);
5634 gfc_add_ss_to_loop (loop, *ss);
5635 gfc_add_ss_to_loop (loop, se->ss);
5636 gfc_conv_ss_startstride (loop);
5637 gfc_conv_loop_setup (loop, where);
5638 gfc_copy_loopinfo_to_se (se, loop);
5639 gfc_add_block_to_block (&se->pre, &loop->pre);
5640 gfc_add_block_to_block (&se->pre, &loop->post);
5641 se->ss->is_alloc_lhs = 0;
5645 /* For Assignment to a reallocatable lhs from intrinsic functions,
5646 replace the se.expr (ie. the result) with a temporary descriptor.
5647 Null the data field so that the library allocates space for the
5648 result. Free the data of the original descriptor after the function,
5649 in case it appears in an argument expression and transfer the
5650 result to the original descriptor. */
5653 fcncall_realloc_result (gfc_se *se, int rank)
5661 /* Use the allocation done by the library. Substitute the lhs
5662 descriptor with a copy, whose data field is nulled.*/
5663 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5664 /* Unallocated, the descriptor does not have a dtype. */
5665 tmp = gfc_conv_descriptor_dtype (desc);
5666 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5667 res_desc = gfc_evaluate_now (desc, &se->pre);
5668 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5669 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5671 /* Free the lhs after the function call and copy the result to
5672 the lhs descriptor. */
5673 tmp = gfc_conv_descriptor_data_get (desc);
5674 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5675 gfc_add_expr_to_block (&se->post, tmp);
5676 gfc_add_modify (&se->post, desc, res_desc);
5678 offset = gfc_index_zero_node;
5679 tmp = gfc_index_one_node;
5680 /* Now reset the bounds from zero based to unity based. */
5681 for (n = 0 ; n < rank; n++)
5683 /* Accumulate the offset. */
5684 offset = fold_build2_loc (input_location, MINUS_EXPR,
5685 gfc_array_index_type,
5687 /* Now do the bounds. */
5688 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5689 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5690 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5691 gfc_array_index_type,
5692 tmp, gfc_index_one_node);
5693 gfc_conv_descriptor_lbound_set (&se->post, desc,
5695 gfc_index_one_node);
5696 gfc_conv_descriptor_ubound_set (&se->post, desc,
5697 gfc_rank_cst[n], tmp);
5699 /* The extent for the next contribution to offset. */
5700 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5701 gfc_array_index_type,
5702 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5703 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5704 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5705 gfc_array_index_type,
5706 tmp, gfc_index_one_node);
5708 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5713 /* Try to translate array(:) = func (...), where func is a transformational
5714 array function, without using a temporary. Returns NULL if this isn't the
5718 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5722 gfc_component *comp = NULL;
5725 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5728 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5730 gcc_assert (expr2->value.function.isym
5731 || (gfc_is_proc_ptr_comp (expr2, &comp)
5732 && comp && comp->attr.dimension)
5733 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5734 && expr2->value.function.esym->result->attr.dimension));
5736 ss = gfc_walk_expr (expr1);
5737 gcc_assert (ss != gfc_ss_terminator);
5738 gfc_init_se (&se, NULL);
5739 gfc_start_block (&se.pre);
5740 se.want_pointer = 1;
5742 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5744 if (expr1->ts.type == BT_DERIVED
5745 && expr1->ts.u.derived->attr.alloc_comp)
5748 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5750 gfc_add_expr_to_block (&se.pre, tmp);
5753 se.direct_byref = 1;
5754 se.ss = gfc_walk_expr (expr2);
5755 gcc_assert (se.ss != gfc_ss_terminator);
5757 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5758 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5759 Clearly, this cannot be done for an allocatable function result, since
5760 the shape of the result is unknown and, in any case, the function must
5761 correctly take care of the reallocation internally. For intrinsic
5762 calls, the array data is freed and the library takes care of allocation.
5763 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5765 if (gfc_option.flag_realloc_lhs
5766 && gfc_is_reallocatable_lhs (expr1)
5767 && !gfc_expr_attr (expr1).codimension
5768 && !gfc_is_coindexed (expr1)
5769 && !(expr2->value.function.esym
5770 && expr2->value.function.esym->result->attr.allocatable))
5772 if (!expr2->value.function.isym)
5774 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5775 ss->is_alloc_lhs = 1;
5778 fcncall_realloc_result (&se, expr1->rank);
5781 gfc_conv_function_expr (&se, expr2);
5782 gfc_add_block_to_block (&se.pre, &se.post);
5784 return gfc_finish_block (&se.pre);
5788 /* Try to efficiently translate array(:) = 0. Return NULL if this
5792 gfc_trans_zero_assign (gfc_expr * expr)
5794 tree dest, len, type;
5798 sym = expr->symtree->n.sym;
5799 dest = gfc_get_symbol_decl (sym);
5801 type = TREE_TYPE (dest);
5802 if (POINTER_TYPE_P (type))
5803 type = TREE_TYPE (type);
5804 if (!GFC_ARRAY_TYPE_P (type))
5807 /* Determine the length of the array. */
5808 len = GFC_TYPE_ARRAY_SIZE (type);
5809 if (!len || TREE_CODE (len) != INTEGER_CST)
5812 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5813 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5814 fold_convert (gfc_array_index_type, tmp));
5816 /* If we are zeroing a local array avoid taking its address by emitting
5818 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5819 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5820 dest, build_constructor (TREE_TYPE (dest), NULL));
5822 /* Convert arguments to the correct types. */
5823 dest = fold_convert (pvoid_type_node, dest);
5824 len = fold_convert (size_type_node, len);
5826 /* Construct call to __builtin_memset. */
5827 tmp = build_call_expr_loc (input_location,
5828 builtin_decl_explicit (BUILT_IN_MEMSET),
5829 3, dest, integer_zero_node, len);
5830 return fold_convert (void_type_node, tmp);
5834 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5835 that constructs the call to __builtin_memcpy. */
5838 gfc_build_memcpy_call (tree dst, tree src, tree len)
5842 /* Convert arguments to the correct types. */
5843 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5844 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5846 dst = fold_convert (pvoid_type_node, dst);
5848 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5849 src = gfc_build_addr_expr (pvoid_type_node, src);
5851 src = fold_convert (pvoid_type_node, src);
5853 len = fold_convert (size_type_node, len);
5855 /* Construct call to __builtin_memcpy. */
5856 tmp = build_call_expr_loc (input_location,
5857 builtin_decl_explicit (BUILT_IN_MEMCPY),
5859 return fold_convert (void_type_node, tmp);
5863 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5864 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5865 source/rhs, both are gfc_full_array_ref_p which have been checked for
5869 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5871 tree dst, dlen, dtype;
5872 tree src, slen, stype;
5875 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5876 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5878 dtype = TREE_TYPE (dst);
5879 if (POINTER_TYPE_P (dtype))
5880 dtype = TREE_TYPE (dtype);
5881 stype = TREE_TYPE (src);
5882 if (POINTER_TYPE_P (stype))
5883 stype = TREE_TYPE (stype);
5885 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5888 /* Determine the lengths of the arrays. */
5889 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5890 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5892 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5893 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5894 dlen, fold_convert (gfc_array_index_type, tmp));
5896 slen = GFC_TYPE_ARRAY_SIZE (stype);
5897 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5899 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5900 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5901 slen, fold_convert (gfc_array_index_type, tmp));
5903 /* Sanity check that they are the same. This should always be
5904 the case, as we should already have checked for conformance. */
5905 if (!tree_int_cst_equal (slen, dlen))
5908 return gfc_build_memcpy_call (dst, src, dlen);
5912 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5913 this can't be done. EXPR1 is the destination/lhs for which
5914 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5917 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5919 unsigned HOST_WIDE_INT nelem;
5925 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5929 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5930 dtype = TREE_TYPE (dst);
5931 if (POINTER_TYPE_P (dtype))
5932 dtype = TREE_TYPE (dtype);
5933 if (!GFC_ARRAY_TYPE_P (dtype))
5936 /* Determine the lengths of the array. */
5937 len = GFC_TYPE_ARRAY_SIZE (dtype);
5938 if (!len || TREE_CODE (len) != INTEGER_CST)
5941 /* Confirm that the constructor is the same size. */
5942 if (compare_tree_int (len, nelem) != 0)
5945 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5946 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5947 fold_convert (gfc_array_index_type, tmp));
5949 stype = gfc_typenode_for_spec (&expr2->ts);
5950 src = gfc_build_constant_array_constructor (expr2, stype);
5952 stype = TREE_TYPE (src);
5953 if (POINTER_TYPE_P (stype))
5954 stype = TREE_TYPE (stype);
5956 return gfc_build_memcpy_call (dst, src, len);
5960 /* Tells whether the expression is to be treated as a variable reference. */
5963 expr_is_variable (gfc_expr *expr)
5967 if (expr->expr_type == EXPR_VARIABLE)
5970 arg = gfc_get_noncopying_intrinsic_argument (expr);
5973 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5974 return expr_is_variable (arg);
5981 /* Is the lhs OK for automatic reallocation? */
5984 is_scalar_reallocatable_lhs (gfc_expr *expr)
5988 /* An allocatable variable with no reference. */
5989 if (expr->symtree->n.sym->attr.allocatable
5993 /* All that can be left are allocatable components. */
5994 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5995 && expr->symtree->n.sym->ts.type != BT_CLASS)
5996 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5999 /* Find an allocatable component ref last. */
6000 for (ref = expr->ref; ref; ref = ref->next)
6001 if (ref->type == REF_COMPONENT
6003 && ref->u.c.component->attr.allocatable)
6010 /* Allocate or reallocate scalar lhs, as necessary. */
6013 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6027 if (!expr1 || expr1->rank)
6030 if (!expr2 || expr2->rank)
6033 /* Since this is a scalar lhs, we can afford to do this. That is,
6034 there is no risk of side effects being repeated. */
6035 gfc_init_se (&lse, NULL);
6036 lse.want_pointer = 1;
6037 gfc_conv_expr (&lse, expr1);
6039 jump_label1 = gfc_build_label_decl (NULL_TREE);
6040 jump_label2 = gfc_build_label_decl (NULL_TREE);
6042 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6043 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6044 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6046 tmp = build3_v (COND_EXPR, cond,
6047 build1_v (GOTO_EXPR, jump_label1),
6048 build_empty_stmt (input_location));
6049 gfc_add_expr_to_block (block, tmp);
6051 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6053 /* Use the rhs string length and the lhs element size. */
6054 size = string_length;
6055 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6056 tmp = TYPE_SIZE_UNIT (tmp);
6057 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6058 TREE_TYPE (tmp), tmp,
6059 fold_convert (TREE_TYPE (tmp), size));
6063 /* Otherwise use the length in bytes of the rhs. */
6064 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6065 size_in_bytes = size;
6068 tmp = build_call_expr_loc (input_location,
6069 builtin_decl_explicit (BUILT_IN_MALLOC),
6071 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6072 gfc_add_modify (block, lse.expr, tmp);
6073 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6075 /* Deferred characters need checking for lhs and rhs string
6076 length. Other deferred parameter variables will have to
6078 tmp = build1_v (GOTO_EXPR, jump_label2);
6079 gfc_add_expr_to_block (block, tmp);
6081 tmp = build1_v (LABEL_EXPR, jump_label1);
6082 gfc_add_expr_to_block (block, tmp);
6084 /* For a deferred length character, reallocate if lengths of lhs and
6085 rhs are different. */
6086 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6088 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6089 expr1->ts.u.cl->backend_decl, size);
6090 /* Jump past the realloc if the lengths are the same. */
6091 tmp = build3_v (COND_EXPR, cond,
6092 build1_v (GOTO_EXPR, jump_label2),
6093 build_empty_stmt (input_location));
6094 gfc_add_expr_to_block (block, tmp);
6095 tmp = build_call_expr_loc (input_location,
6096 builtin_decl_explicit (BUILT_IN_REALLOC),
6097 2, fold_convert (pvoid_type_node, lse.expr),
6099 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6100 gfc_add_modify (block, lse.expr, tmp);
6101 tmp = build1_v (LABEL_EXPR, jump_label2);
6102 gfc_add_expr_to_block (block, tmp);
6104 /* Update the lhs character length. */
6105 size = string_length;
6106 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6111 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6112 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6113 init_flag indicates initialization expressions and dealloc that no
6114 deallocate prior assignment is needed (if in doubt, set true). */
6117 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6123 gfc_ss *lss_section;
6130 bool scalar_to_array;
6135 /* Assignment of the form lhs = rhs. */
6136 gfc_start_block (&block);
6138 gfc_init_se (&lse, NULL);
6139 gfc_init_se (&rse, NULL);
6142 lss = gfc_walk_expr (expr1);
6143 if (gfc_is_reallocatable_lhs (expr1)
6144 && !(expr2->expr_type == EXPR_FUNCTION
6145 && expr2->value.function.isym != NULL))
6146 lss->is_alloc_lhs = 1;
6148 if (lss != gfc_ss_terminator)
6150 /* The assignment needs scalarization. */
6153 /* Find a non-scalar SS from the lhs. */
6154 while (lss_section != gfc_ss_terminator
6155 && lss_section->type != GFC_SS_SECTION)
6156 lss_section = lss_section->next;
6158 gcc_assert (lss_section != gfc_ss_terminator);
6160 /* Initialize the scalarizer. */
6161 gfc_init_loopinfo (&loop);
6164 rss = gfc_walk_expr (expr2);
6165 if (rss == gfc_ss_terminator)
6166 /* The rhs is scalar. Add a ss for the expression. */
6167 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6169 /* Associate the SS with the loop. */
6170 gfc_add_ss_to_loop (&loop, lss);
6171 gfc_add_ss_to_loop (&loop, rss);
6173 /* Calculate the bounds of the scalarization. */
6174 gfc_conv_ss_startstride (&loop);
6175 /* Enable loop reversal. */
6176 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6177 loop.reverse[n] = GFC_ENABLE_REVERSE;
6178 /* Resolve any data dependencies in the statement. */
6179 gfc_conv_resolve_dependencies (&loop, lss, rss);
6180 /* Setup the scalarizing loops. */
6181 gfc_conv_loop_setup (&loop, &expr2->where);
6183 /* Setup the gfc_se structures. */
6184 gfc_copy_loopinfo_to_se (&lse, &loop);
6185 gfc_copy_loopinfo_to_se (&rse, &loop);
6188 gfc_mark_ss_chain_used (rss, 1);
6189 if (loop.temp_ss == NULL)
6192 gfc_mark_ss_chain_used (lss, 1);
6196 lse.ss = loop.temp_ss;
6197 gfc_mark_ss_chain_used (lss, 3);
6198 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6201 /* Allow the scalarizer to workshare array assignments. */
6202 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6203 ompws_flags |= OMPWS_SCALARIZER_WS;
6205 /* Start the scalarized loop body. */
6206 gfc_start_scalarized_body (&loop, &body);
6209 gfc_init_block (&body);
6211 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6213 /* Translate the expression. */
6214 gfc_conv_expr (&rse, expr2);
6216 /* Stabilize a string length for temporaries. */
6217 if (expr2->ts.type == BT_CHARACTER)
6218 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6220 string_length = NULL_TREE;
6224 gfc_conv_tmp_array_ref (&lse);
6225 if (expr2->ts.type == BT_CHARACTER)
6226 lse.string_length = string_length;
6229 gfc_conv_expr (&lse, expr1);
6231 /* Assignments of scalar derived types with allocatable components
6232 to arrays must be done with a deep copy and the rhs temporary
6233 must have its components deallocated afterwards. */
6234 scalar_to_array = (expr2->ts.type == BT_DERIVED
6235 && expr2->ts.u.derived->attr.alloc_comp
6236 && !expr_is_variable (expr2)
6237 && !gfc_is_constant_expr (expr2)
6238 && expr1->rank && !expr2->rank);
6239 if (scalar_to_array && dealloc)
6241 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6242 gfc_add_expr_to_block (&loop.post, tmp);
6245 /* For a deferred character length function, the function call must
6246 happen before the (re)allocation of the lhs, otherwise the character
6247 length of the result is not known. */
6248 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6249 || (expr2->expr_type == EXPR_COMPCALL)
6250 || (expr2->expr_type == EXPR_PPC))
6251 && expr2->ts.deferred);
6252 if (gfc_option.flag_realloc_lhs
6253 && expr2->ts.type == BT_CHARACTER
6254 && (def_clen_func || expr2->expr_type == EXPR_OP)
6255 && expr1->ts.deferred)
6256 gfc_add_block_to_block (&block, &rse.pre);
6258 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6259 l_is_temp || init_flag,
6260 expr_is_variable (expr2) || scalar_to_array
6261 || expr2->expr_type == EXPR_ARRAY, dealloc);
6262 gfc_add_expr_to_block (&body, tmp);
6264 if (lss == gfc_ss_terminator)
6266 /* F2003: Add the code for reallocation on assignment. */
6267 if (gfc_option.flag_realloc_lhs
6268 && is_scalar_reallocatable_lhs (expr1))
6269 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6272 /* Use the scalar assignment as is. */
6273 gfc_add_block_to_block (&block, &body);
6277 gcc_assert (lse.ss == gfc_ss_terminator
6278 && rse.ss == gfc_ss_terminator);
6282 gfc_trans_scalarized_loop_boundary (&loop, &body);
6284 /* We need to copy the temporary to the actual lhs. */
6285 gfc_init_se (&lse, NULL);
6286 gfc_init_se (&rse, NULL);
6287 gfc_copy_loopinfo_to_se (&lse, &loop);
6288 gfc_copy_loopinfo_to_se (&rse, &loop);
6290 rse.ss = loop.temp_ss;
6293 gfc_conv_tmp_array_ref (&rse);
6294 gfc_conv_expr (&lse, expr1);
6296 gcc_assert (lse.ss == gfc_ss_terminator
6297 && rse.ss == gfc_ss_terminator);
6299 if (expr2->ts.type == BT_CHARACTER)
6300 rse.string_length = string_length;
6302 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6303 false, false, dealloc);
6304 gfc_add_expr_to_block (&body, tmp);
6307 /* F2003: Allocate or reallocate lhs of allocatable array. */
6308 if (gfc_option.flag_realloc_lhs
6309 && gfc_is_reallocatable_lhs (expr1)
6310 && !gfc_expr_attr (expr1).codimension
6311 && !gfc_is_coindexed (expr1))
6313 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6314 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6315 if (tmp != NULL_TREE)
6316 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6319 /* Generate the copying loops. */
6320 gfc_trans_scalarizing_loops (&loop, &body);
6322 /* Wrap the whole thing up. */
6323 gfc_add_block_to_block (&block, &loop.pre);
6324 gfc_add_block_to_block (&block, &loop.post);
6326 gfc_cleanup_loop (&loop);
6329 return gfc_finish_block (&block);
6333 /* Check whether EXPR is a copyable array. */
6336 copyable_array_p (gfc_expr * expr)
6338 if (expr->expr_type != EXPR_VARIABLE)
6341 /* First check it's an array. */
6342 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6345 if (!gfc_full_array_ref_p (expr->ref, NULL))
6348 /* Next check that it's of a simple enough type. */
6349 switch (expr->ts.type)
6361 return !expr->ts.u.derived->attr.alloc_comp;
6370 /* Translate an assignment. */
6373 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6378 /* Special case a single function returning an array. */
6379 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6381 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6386 /* Special case assigning an array to zero. */
6387 if (copyable_array_p (expr1)
6388 && is_zero_initializer_p (expr2))
6390 tmp = gfc_trans_zero_assign (expr1);
6395 /* Special case copying one array to another. */
6396 if (copyable_array_p (expr1)
6397 && copyable_array_p (expr2)
6398 && gfc_compare_types (&expr1->ts, &expr2->ts)
6399 && !gfc_check_dependency (expr1, expr2, 0))
6401 tmp = gfc_trans_array_copy (expr1, expr2);
6406 /* Special case initializing an array from a constant array constructor. */
6407 if (copyable_array_p (expr1)
6408 && expr2->expr_type == EXPR_ARRAY
6409 && gfc_compare_types (&expr1->ts, &expr2->ts))
6411 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6416 /* Fallback to the scalarizer to generate explicit loops. */
6417 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6421 gfc_trans_init_assign (gfc_code * code)
6423 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6427 gfc_trans_assign (gfc_code * code)
6429 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6433 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6434 A MEMCPY is needed to copy the full data from the default initializer
6435 of the dynamic type. */
6438 gfc_trans_class_init_assign (gfc_code *code)
6442 gfc_se dst,src,memsz;
6443 gfc_expr *lhs,*rhs,*sz;
6445 gfc_start_block (&block);
6447 lhs = gfc_copy_expr (code->expr1);
6448 gfc_add_data_component (lhs);
6450 rhs = gfc_copy_expr (code->expr1);
6451 gfc_add_vptr_component (rhs);
6453 /* Make sure that the component backend_decls have been built, which
6454 will not have happened if the derived types concerned have not
6456 gfc_get_derived_type (rhs->ts.u.derived);
6457 gfc_add_def_init_component (rhs);
6459 sz = gfc_copy_expr (code->expr1);
6460 gfc_add_vptr_component (sz);
6461 gfc_add_size_component (sz);
6463 gfc_init_se (&dst, NULL);
6464 gfc_init_se (&src, NULL);
6465 gfc_init_se (&memsz, NULL);
6466 gfc_conv_expr (&dst, lhs);
6467 gfc_conv_expr (&src, rhs);
6468 gfc_conv_expr (&memsz, sz);
6469 gfc_add_block_to_block (&block, &src.pre);
6470 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6471 gfc_add_expr_to_block (&block, tmp);
6473 return gfc_finish_block (&block);
6477 /* Translate an assignment to a CLASS object
6478 (pointer or ordinary assignment). */
6481 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6488 gfc_start_block (&block);
6490 if (expr2->ts.type != BT_CLASS)
6492 /* Insert an additional assignment which sets the '_vptr' field. */
6493 gfc_symbol *vtab = NULL;
6496 lhs = gfc_copy_expr (expr1);
6497 gfc_add_vptr_component (lhs);
6499 if (expr2->ts.type == BT_DERIVED)
6500 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6501 else if (expr2->expr_type == EXPR_NULL)
6502 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6505 rhs = gfc_get_expr ();
6506 rhs->expr_type = EXPR_VARIABLE;
6507 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6511 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6512 gfc_add_expr_to_block (&block, tmp);
6514 gfc_free_expr (lhs);
6515 gfc_free_expr (rhs);
6518 /* Do the actual CLASS assignment. */
6519 if (expr2->ts.type == BT_CLASS)
6522 gfc_add_data_component (expr1);
6524 if (op == EXEC_ASSIGN)
6525 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6526 else if (op == EXEC_POINTER_ASSIGN)
6527 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6531 gfc_add_expr_to_block (&block, tmp);
6533 return gfc_finish_block (&block);