1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym->attr.pointer && !sym->attr.allocatable
148 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
149 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
152 tmp = build_fold_indirect_ref_loc (input_location, decl);
153 tmp = gfc_conv_array_data (tmp);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 fold_convert (TREE_TYPE (tmp), null_pointer_node));
156 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
157 boolean_type_node, cond, tmp);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
172 present = gfc_conv_expr_present (arg->symtree->n.sym);
176 /* Create a temporary and convert it to the correct type. */
177 tmp = gfc_get_int_type (kind);
178 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
181 /* Test for a NULL value. */
182 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
183 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
189 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
191 build_zero_cst (TREE_TYPE (se->expr)));
192 tmp = gfc_evaluate_now (tmp, &se->pre);
196 if (ts.type == BT_CHARACTER)
198 tmp = build_int_cst (gfc_charlen_type_node, 0);
199 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
200 present, se->string_length, tmp);
201 tmp = gfc_evaluate_now (tmp, &se->pre);
202 se->string_length = tmp;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr *e)
217 gcc_assert (e->expr_type == EXPR_VARIABLE
218 && e->ts.type == BT_CHARACTER);
220 length = NULL; /* To silence compiler warning. */
222 if (is_subref_array (e) && e->ts.u.cl->length)
225 gfc_init_se (&tmpse, NULL);
226 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
227 e->ts.u.cl->backend_decl = tmpse.expr;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
235 length = e->symtree->n.sym->ts.u.cl->backend_decl;
237 /* Look through the reference chain for component references. */
238 for (r = e->ref; r; r = r->next)
243 if (r->u.c.component->ts.type == BT_CHARACTER)
244 length = r->u.c.component->ts.u.cl->backend_decl;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length != NULL);
264 /* Return for an expression the backend decl of the coarray. */
267 get_tree_for_caf_expr (gfc_expr *expr)
269 tree caf_decl = NULL_TREE;
272 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
273 if (expr->symtree->n.sym->attr.codimension)
274 caf_decl = expr->symtree->n.sym->backend_decl;
276 for (ref = expr->ref; ref; ref = ref->next)
277 if (ref->type == REF_COMPONENT)
279 gfc_component *comp = ref->u.c.component;
280 if (comp->attr.pointer || comp->attr.allocatable)
281 caf_decl = NULL_TREE;
282 if (comp->attr.codimension)
283 caf_decl = comp->backend_decl;
286 gcc_assert (caf_decl != NULL_TREE);
291 /* For each character array constructor subexpression without a ts.u.cl->length,
292 replace it by its first element (if there aren't any elements, the length
293 should already be set to zero). */
296 flatten_array_ctors_without_strlen (gfc_expr* e)
298 gfc_actual_arglist* arg;
304 switch (e->expr_type)
308 flatten_array_ctors_without_strlen (e->value.op.op1);
309 flatten_array_ctors_without_strlen (e->value.op.op2);
313 /* TODO: Implement as with EXPR_FUNCTION when needed. */
317 for (arg = e->value.function.actual; arg; arg = arg->next)
318 flatten_array_ctors_without_strlen (arg->expr);
323 /* We've found what we're looking for. */
324 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
329 gcc_assert (e->value.constructor);
331 c = gfc_constructor_first (e->value.constructor);
335 flatten_array_ctors_without_strlen (new_expr);
336 gfc_replace_expr (e, new_expr);
340 /* Otherwise, fall through to handle constructor elements. */
342 for (c = gfc_constructor_first (e->value.constructor);
343 c; c = gfc_constructor_next (c))
344 flatten_array_ctors_without_strlen (c->expr);
354 /* Generate code to initialize a string length variable. Returns the
355 value. For array constructors, cl->length might be NULL and in this case,
356 the first element of the constructor is needed. expr is the original
357 expression so we can access it but can be NULL if this is not needed. */
360 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
364 gfc_init_se (&se, NULL);
368 && TREE_CODE (cl->backend_decl) == VAR_DECL)
371 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
372 "flatten" array constructors by taking their first element; all elements
373 should be the same length or a cl->length should be present. */
378 expr_flat = gfc_copy_expr (expr);
379 flatten_array_ctors_without_strlen (expr_flat);
380 gfc_resolve_expr (expr_flat);
382 gfc_conv_expr (&se, expr_flat);
383 gfc_add_block_to_block (pblock, &se.pre);
384 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
386 gfc_free_expr (expr_flat);
390 /* Convert cl->length. */
392 gcc_assert (cl->length);
394 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
395 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
396 se.expr, build_int_cst (gfc_charlen_type_node, 0));
397 gfc_add_block_to_block (pblock, &se.pre);
399 if (cl->backend_decl)
400 gfc_add_modify (pblock, cl->backend_decl, se.expr);
402 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
407 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
408 const char *name, locus *where)
417 type = gfc_get_character_type (kind, ref->u.ss.length);
418 type = build_pointer_type (type);
420 gfc_init_se (&start, se);
421 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
422 gfc_add_block_to_block (&se->pre, &start.pre);
424 if (integer_onep (start.expr))
425 gfc_conv_string_parameter (se);
430 /* Avoid multiple evaluation of substring start. */
431 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
432 start.expr = gfc_evaluate_now (start.expr, &se->pre);
434 /* Change the start of the string. */
435 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
438 tmp = build_fold_indirect_ref_loc (input_location,
440 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
441 se->expr = gfc_build_addr_expr (type, tmp);
444 /* Length = end + 1 - start. */
445 gfc_init_se (&end, se);
446 if (ref->u.ss.end == NULL)
447 end.expr = se->string_length;
450 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
451 gfc_add_block_to_block (&se->pre, &end.pre);
455 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
456 end.expr = gfc_evaluate_now (end.expr, &se->pre);
458 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
460 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
461 boolean_type_node, start.expr,
464 /* Check lower bound. */
465 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
467 build_int_cst (gfc_charlen_type_node, 1));
468 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
469 boolean_type_node, nonempty, fault);
471 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
472 "is less than one", name);
474 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
476 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
477 fold_convert (long_integer_type_node,
481 /* Check upper bound. */
482 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
483 end.expr, se->string_length);
484 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
485 boolean_type_node, nonempty, fault);
487 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
488 "exceeds string length (%%ld)", name);
490 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
491 "exceeds string length (%%ld)");
492 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
493 fold_convert (long_integer_type_node, end.expr),
494 fold_convert (long_integer_type_node,
499 /* If the start and end expressions are equal, the length is one. */
501 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
502 tmp = build_int_cst (gfc_charlen_type_node, 1);
505 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
506 end.expr, start.expr);
507 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
508 build_int_cst (gfc_charlen_type_node, 1), tmp);
509 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
510 tmp, build_int_cst (gfc_charlen_type_node, 0));
513 se->string_length = tmp;
517 /* Convert a derived type component reference. */
520 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
527 c = ref->u.c.component;
529 gcc_assert (c->backend_decl);
531 field = c->backend_decl;
532 gcc_assert (TREE_CODE (field) == FIELD_DECL);
535 /* Components can correspond to fields of different containing
536 types, as components are created without context, whereas
537 a concrete use of a component has the type of decl as context.
538 So, if the type doesn't match, we search the corresponding
539 FIELD_DECL in the parent type. To not waste too much time
540 we cache this result in norestrict_decl. */
542 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
544 tree f2 = c->norestrict_decl;
545 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
546 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
547 if (TREE_CODE (f2) == FIELD_DECL
548 && DECL_NAME (f2) == DECL_NAME (field))
551 c->norestrict_decl = f2;
554 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
555 decl, field, NULL_TREE);
559 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
561 tmp = c->ts.u.cl->backend_decl;
562 /* Components must always be constant length. */
563 gcc_assert (tmp && INTEGER_CST_P (tmp));
564 se->string_length = tmp;
567 if (((c->attr.pointer || c->attr.allocatable)
568 && (!c->attr.dimension && !c->attr.codimension)
569 && c->ts.type != BT_CHARACTER)
570 || c->attr.proc_pointer)
571 se->expr = build_fold_indirect_ref_loc (input_location,
576 /* This function deals with component references to components of the
577 parent type for derived type extensons. */
579 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
587 c = ref->u.c.component;
589 /* Return if the component is not in the parent type. */
590 for (cmp = dt->components; cmp; cmp = cmp->next)
591 if (strcmp (c->name, cmp->name) == 0)
594 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
595 parent.type = REF_COMPONENT;
598 parent.u.c.component = dt->components;
600 if (dt->backend_decl == NULL)
601 gfc_get_derived_type (dt);
603 /* Build the reference and call self. */
604 gfc_conv_component_ref (se, &parent);
605 parent.u.c.sym = dt->components->ts.u.derived;
606 parent.u.c.component = c;
607 conv_parent_component_references (se, &parent);
610 /* Return the contents of a variable. Also handles reference/pointer
611 variables (all Fortran pointer references are implicit). */
614 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
618 tree parent_decl = NULL_TREE;
621 bool alternate_entry;
624 sym = expr->symtree->n.sym;
627 /* Check that something hasn't gone horribly wrong. */
628 gcc_assert (se->ss != gfc_ss_terminator);
629 gcc_assert (se->ss->expr == expr);
631 /* A scalarized term. We already know the descriptor. */
632 se->expr = se->ss->data.info.descriptor;
633 se->string_length = se->ss->string_length;
634 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
635 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
640 tree se_expr = NULL_TREE;
642 se->expr = gfc_get_symbol_decl (sym);
644 /* Deal with references to a parent results or entries by storing
645 the current_function_decl and moving to the parent_decl. */
646 return_value = sym->attr.function && sym->result == sym;
647 alternate_entry = sym->attr.function && sym->attr.entry
648 && sym->result == sym;
649 entry_master = sym->attr.result
650 && sym->ns->proc_name->attr.entry_master
651 && !gfc_return_by_reference (sym->ns->proc_name);
652 if (current_function_decl)
653 parent_decl = DECL_CONTEXT (current_function_decl);
655 if ((se->expr == parent_decl && return_value)
656 || (sym->ns && sym->ns->proc_name
658 && sym->ns->proc_name->backend_decl == parent_decl
659 && (alternate_entry || entry_master)))
664 /* Special case for assigning the return value of a function.
665 Self recursive functions must have an explicit return value. */
666 if (return_value && (se->expr == current_function_decl || parent_flag))
667 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
669 /* Similarly for alternate entry points. */
670 else if (alternate_entry
671 && (sym->ns->proc_name->backend_decl == current_function_decl
674 gfc_entry_list *el = NULL;
676 for (el = sym->ns->entries; el; el = el->next)
679 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
684 else if (entry_master
685 && (sym->ns->proc_name->backend_decl == current_function_decl
687 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
692 /* Procedure actual arguments. */
693 else if (sym->attr.flavor == FL_PROCEDURE
694 && se->expr != current_function_decl)
696 if (!sym->attr.dummy && !sym->attr.proc_pointer)
698 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
699 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
705 /* Dereference the expression, where needed. Since characters
706 are entirely different from other types, they are treated
708 if (sym->ts.type == BT_CHARACTER)
710 /* Dereference character pointer dummy arguments
712 if ((sym->attr.pointer || sym->attr.allocatable)
714 || sym->attr.function
715 || sym->attr.result))
716 se->expr = build_fold_indirect_ref_loc (input_location,
720 else if (!sym->attr.value)
722 /* Dereference non-character scalar dummy arguments. */
723 if (sym->attr.dummy && !sym->attr.dimension
724 && !(sym->attr.codimension && sym->attr.allocatable))
725 se->expr = build_fold_indirect_ref_loc (input_location,
728 /* Dereference scalar hidden result. */
729 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
730 && (sym->attr.function || sym->attr.result)
731 && !sym->attr.dimension && !sym->attr.pointer
732 && !sym->attr.always_explicit)
733 se->expr = build_fold_indirect_ref_loc (input_location,
736 /* Dereference non-character pointer variables.
737 These must be dummies, results, or scalars. */
738 if ((sym->attr.pointer || sym->attr.allocatable
739 || gfc_is_associate_pointer (sym))
741 || sym->attr.function
743 || (!sym->attr.dimension
744 && (!sym->attr.codimension || !sym->attr.allocatable))))
745 se->expr = build_fold_indirect_ref_loc (input_location,
752 /* For character variables, also get the length. */
753 if (sym->ts.type == BT_CHARACTER)
755 /* If the character length of an entry isn't set, get the length from
756 the master function instead. */
757 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
758 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
760 se->string_length = sym->ts.u.cl->backend_decl;
761 gcc_assert (se->string_length);
769 /* Return the descriptor if that's what we want and this is an array
770 section reference. */
771 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
773 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
774 /* Return the descriptor for array pointers and allocations. */
776 && ref->next == NULL && (se->descriptor_only))
779 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
780 /* Return a pointer to an element. */
784 if (ref->u.c.sym->attr.extension)
785 conv_parent_component_references (se, ref);
787 gfc_conv_component_ref (se, ref);
791 gfc_conv_substring (se, ref, expr->ts.kind,
792 expr->symtree->name, &expr->where);
801 /* Pointer assignment, allocation or pass by reference. Arrays are handled
803 if (se->want_pointer)
805 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
806 gfc_conv_string_parameter (se);
808 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
813 /* Unary ops are easy... Or they would be if ! was a valid op. */
816 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
821 gcc_assert (expr->ts.type != BT_CHARACTER);
822 /* Initialize the operand. */
823 gfc_init_se (&operand, se);
824 gfc_conv_expr_val (&operand, expr->value.op.op1);
825 gfc_add_block_to_block (&se->pre, &operand.pre);
827 type = gfc_typenode_for_spec (&expr->ts);
829 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
830 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
831 All other unary operators have an equivalent GIMPLE unary operator. */
832 if (code == TRUTH_NOT_EXPR)
833 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
834 build_int_cst (type, 0));
836 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
840 /* Expand power operator to optimal multiplications when a value is raised
841 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
842 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
843 Programming", 3rd Edition, 1998. */
845 /* This code is mostly duplicated from expand_powi in the backend.
846 We establish the "optimal power tree" lookup table with the defined size.
847 The items in the table are the exponents used to calculate the index
848 exponents. Any integer n less than the value can get an "addition chain",
849 with the first node being one. */
850 #define POWI_TABLE_SIZE 256
852 /* The table is from builtins.c. */
853 static const unsigned char powi_table[POWI_TABLE_SIZE] =
855 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
856 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
857 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
858 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
859 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
860 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
861 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
862 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
863 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
864 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
865 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
866 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
867 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
868 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
869 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
870 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
871 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
872 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
873 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
874 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
875 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
876 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
877 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
878 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
879 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
880 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
881 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
882 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
883 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
884 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
885 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
886 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
889 /* If n is larger than lookup table's max index, we use the "window
891 #define POWI_WINDOW_SIZE 3
893 /* Recursive function to expand the power operator. The temporary
894 values are put in tmpvar. The function returns tmpvar[1] ** n. */
896 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
903 if (n < POWI_TABLE_SIZE)
908 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
909 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
913 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
914 op0 = gfc_conv_powi (se, n - digit, tmpvar);
915 op1 = gfc_conv_powi (se, digit, tmpvar);
919 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
923 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
924 tmp = gfc_evaluate_now (tmp, &se->pre);
926 if (n < POWI_TABLE_SIZE)
933 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
934 return 1. Else return 0 and a call to runtime library functions
935 will have to be built. */
937 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
942 tree vartmp[POWI_TABLE_SIZE];
944 unsigned HOST_WIDE_INT n;
947 /* If exponent is too large, we won't expand it anyway, so don't bother
948 with large integer values. */
949 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
952 m = double_int_to_shwi (TREE_INT_CST (rhs));
953 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
954 of the asymmetric range of the integer type. */
955 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
957 type = TREE_TYPE (lhs);
958 sgn = tree_int_cst_sgn (rhs);
960 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
961 || optimize_size) && (m > 2 || m < -1))
967 se->expr = gfc_build_const (type, integer_one_node);
971 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
972 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
974 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
975 lhs, build_int_cst (TREE_TYPE (lhs), -1));
976 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
977 lhs, build_int_cst (TREE_TYPE (lhs), 1));
980 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
983 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
984 boolean_type_node, tmp, cond);
985 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
986 tmp, build_int_cst (type, 1),
987 build_int_cst (type, 0));
991 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
992 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
993 build_int_cst (type, -1),
994 build_int_cst (type, 0));
995 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
996 cond, build_int_cst (type, 1), tmp);
1000 memset (vartmp, 0, sizeof (vartmp));
1004 tmp = gfc_build_const (type, integer_one_node);
1005 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1009 se->expr = gfc_conv_powi (se, n, vartmp);
1015 /* Power op (**). Constant integer exponent has special handling. */
1018 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1020 tree gfc_int4_type_node;
1023 int res_ikind_1, res_ikind_2;
1028 gfc_init_se (&lse, se);
1029 gfc_conv_expr_val (&lse, expr->value.op.op1);
1030 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1031 gfc_add_block_to_block (&se->pre, &lse.pre);
1033 gfc_init_se (&rse, se);
1034 gfc_conv_expr_val (&rse, expr->value.op.op2);
1035 gfc_add_block_to_block (&se->pre, &rse.pre);
1037 if (expr->value.op.op2->ts.type == BT_INTEGER
1038 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1039 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1042 gfc_int4_type_node = gfc_get_int_type (4);
1044 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1045 library routine. But in the end, we have to convert the result back
1046 if this case applies -- with res_ikind_K, we keep track whether operand K
1047 falls into this case. */
1051 kind = expr->value.op.op1->ts.kind;
1052 switch (expr->value.op.op2->ts.type)
1055 ikind = expr->value.op.op2->ts.kind;
1060 rse.expr = convert (gfc_int4_type_node, rse.expr);
1061 res_ikind_2 = ikind;
1083 if (expr->value.op.op1->ts.type == BT_INTEGER)
1085 lse.expr = convert (gfc_int4_type_node, lse.expr);
1112 switch (expr->value.op.op1->ts.type)
1115 if (kind == 3) /* Case 16 was not handled properly above. */
1117 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1121 /* Use builtins for real ** int4. */
1127 fndecl = built_in_decls[BUILT_IN_POWIF];
1131 fndecl = built_in_decls[BUILT_IN_POWI];
1135 fndecl = built_in_decls[BUILT_IN_POWIL];
1139 /* Use the __builtin_powil() only if real(kind=16) is
1140 actually the C long double type. */
1141 if (!gfc_real16_is_float128)
1142 fndecl = built_in_decls[BUILT_IN_POWIL];
1150 /* If we don't have a good builtin for this, go for the
1151 library function. */
1153 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1157 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1166 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1170 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1178 se->expr = build_call_expr_loc (input_location,
1179 fndecl, 2, lse.expr, rse.expr);
1181 /* Convert the result back if it is of wrong integer kind. */
1182 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1184 /* We want the maximum of both operand kinds as result. */
1185 if (res_ikind_1 < res_ikind_2)
1186 res_ikind_1 = res_ikind_2;
1187 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1192 /* Generate code to allocate a string temporary. */
1195 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1200 if (gfc_can_put_var_on_stack (len))
1202 /* Create a temporary variable to hold the result. */
1203 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1204 gfc_charlen_type_node, len,
1205 build_int_cst (gfc_charlen_type_node, 1));
1206 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1208 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1209 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1211 tmp = build_array_type (TREE_TYPE (type), tmp);
1213 var = gfc_create_var (tmp, "str");
1214 var = gfc_build_addr_expr (type, var);
1218 /* Allocate a temporary to hold the result. */
1219 var = gfc_create_var (type, "pstr");
1220 tmp = gfc_call_malloc (&se->pre, type,
1221 fold_build2_loc (input_location, MULT_EXPR,
1222 TREE_TYPE (len), len,
1223 fold_convert (TREE_TYPE (len),
1224 TYPE_SIZE (type))));
1225 gfc_add_modify (&se->pre, var, tmp);
1227 /* Free the temporary afterwards. */
1228 tmp = gfc_call_free (convert (pvoid_type_node, var));
1229 gfc_add_expr_to_block (&se->post, tmp);
1236 /* Handle a string concatenation operation. A temporary will be allocated to
1240 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1243 tree len, type, var, tmp, fndecl;
1245 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1246 && expr->value.op.op2->ts.type == BT_CHARACTER);
1247 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1249 gfc_init_se (&lse, se);
1250 gfc_conv_expr (&lse, expr->value.op.op1);
1251 gfc_conv_string_parameter (&lse);
1252 gfc_init_se (&rse, se);
1253 gfc_conv_expr (&rse, expr->value.op.op2);
1254 gfc_conv_string_parameter (&rse);
1256 gfc_add_block_to_block (&se->pre, &lse.pre);
1257 gfc_add_block_to_block (&se->pre, &rse.pre);
1259 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1260 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1261 if (len == NULL_TREE)
1263 len = fold_build2_loc (input_location, PLUS_EXPR,
1264 TREE_TYPE (lse.string_length),
1265 lse.string_length, rse.string_length);
1268 type = build_pointer_type (type);
1270 var = gfc_conv_string_tmp (se, type, len);
1272 /* Do the actual concatenation. */
1273 if (expr->ts.kind == 1)
1274 fndecl = gfor_fndecl_concat_string;
1275 else if (expr->ts.kind == 4)
1276 fndecl = gfor_fndecl_concat_string_char4;
1280 tmp = build_call_expr_loc (input_location,
1281 fndecl, 6, len, var, lse.string_length, lse.expr,
1282 rse.string_length, rse.expr);
1283 gfc_add_expr_to_block (&se->pre, tmp);
1285 /* Add the cleanup for the operands. */
1286 gfc_add_block_to_block (&se->pre, &rse.post);
1287 gfc_add_block_to_block (&se->pre, &lse.post);
1290 se->string_length = len;
1293 /* Translates an op expression. Common (binary) cases are handled by this
1294 function, others are passed on. Recursion is used in either case.
1295 We use the fact that (op1.ts == op2.ts) (except for the power
1297 Operators need no special handling for scalarized expressions as long as
1298 they call gfc_conv_simple_val to get their operands.
1299 Character strings get special handling. */
1302 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1304 enum tree_code code;
1313 switch (expr->value.op.op)
1315 case INTRINSIC_PARENTHESES:
1316 if ((expr->ts.type == BT_REAL
1317 || expr->ts.type == BT_COMPLEX)
1318 && gfc_option.flag_protect_parens)
1320 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1321 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1326 case INTRINSIC_UPLUS:
1327 gfc_conv_expr (se, expr->value.op.op1);
1330 case INTRINSIC_UMINUS:
1331 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1335 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1338 case INTRINSIC_PLUS:
1342 case INTRINSIC_MINUS:
1346 case INTRINSIC_TIMES:
1350 case INTRINSIC_DIVIDE:
1351 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1352 an integer, we must round towards zero, so we use a
1354 if (expr->ts.type == BT_INTEGER)
1355 code = TRUNC_DIV_EXPR;
1360 case INTRINSIC_POWER:
1361 gfc_conv_power_op (se, expr);
1364 case INTRINSIC_CONCAT:
1365 gfc_conv_concat_op (se, expr);
1369 code = TRUTH_ANDIF_EXPR;
1374 code = TRUTH_ORIF_EXPR;
1378 /* EQV and NEQV only work on logicals, but since we represent them
1379 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1381 case INTRINSIC_EQ_OS:
1389 case INTRINSIC_NE_OS:
1390 case INTRINSIC_NEQV:
1397 case INTRINSIC_GT_OS:
1404 case INTRINSIC_GE_OS:
1411 case INTRINSIC_LT_OS:
1418 case INTRINSIC_LE_OS:
1424 case INTRINSIC_USER:
1425 case INTRINSIC_ASSIGN:
1426 /* These should be converted into function calls by the frontend. */
1430 fatal_error ("Unknown intrinsic op");
1434 /* The only exception to this is **, which is handled separately anyway. */
1435 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1437 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1441 gfc_init_se (&lse, se);
1442 gfc_conv_expr (&lse, expr->value.op.op1);
1443 gfc_add_block_to_block (&se->pre, &lse.pre);
1446 gfc_init_se (&rse, se);
1447 gfc_conv_expr (&rse, expr->value.op.op2);
1448 gfc_add_block_to_block (&se->pre, &rse.pre);
1452 gfc_conv_string_parameter (&lse);
1453 gfc_conv_string_parameter (&rse);
1455 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1456 rse.string_length, rse.expr,
1457 expr->value.op.op1->ts.kind,
1459 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1460 gfc_add_block_to_block (&lse.post, &rse.post);
1463 type = gfc_typenode_for_spec (&expr->ts);
1467 /* The result of logical ops is always boolean_type_node. */
1468 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1469 lse.expr, rse.expr);
1470 se->expr = convert (type, tmp);
1473 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1475 /* Add the post blocks. */
1476 gfc_add_block_to_block (&se->post, &rse.post);
1477 gfc_add_block_to_block (&se->post, &lse.post);
1480 /* If a string's length is one, we convert it to a single character. */
1483 gfc_string_to_single_character (tree len, tree str, int kind)
1486 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1487 || !POINTER_TYPE_P (TREE_TYPE (str)))
1490 if (TREE_INT_CST_LOW (len) == 1)
1492 str = fold_convert (gfc_get_pchar_type (kind), str);
1493 return build_fold_indirect_ref_loc (input_location, str);
1497 && TREE_CODE (str) == ADDR_EXPR
1498 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1499 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1500 && array_ref_low_bound (TREE_OPERAND (str, 0))
1501 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1502 && TREE_INT_CST_LOW (len) > 1
1503 && TREE_INT_CST_LOW (len)
1504 == (unsigned HOST_WIDE_INT)
1505 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1507 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1508 ret = build_fold_indirect_ref_loc (input_location, ret);
1509 if (TREE_CODE (ret) == INTEGER_CST)
1511 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1512 int i, length = TREE_STRING_LENGTH (string_cst);
1513 const char *ptr = TREE_STRING_POINTER (string_cst);
1515 for (i = 1; i < length; i++)
1528 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1531 if (sym->backend_decl)
1533 /* This becomes the nominal_type in
1534 function.c:assign_parm_find_data_types. */
1535 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1536 /* This becomes the passed_type in
1537 function.c:assign_parm_find_data_types. C promotes char to
1538 integer for argument passing. */
1539 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1541 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1546 /* If we have a constant character expression, make it into an
1548 if ((*expr)->expr_type == EXPR_CONSTANT)
1553 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1554 (int)(*expr)->value.character.string[0]);
1555 if ((*expr)->ts.kind != gfc_c_int_kind)
1557 /* The expr needs to be compatible with a C int. If the
1558 conversion fails, then the 2 causes an ICE. */
1559 ts.type = BT_INTEGER;
1560 ts.kind = gfc_c_int_kind;
1561 gfc_convert_type (*expr, &ts, 2);
1564 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1566 if ((*expr)->ref == NULL)
1568 se->expr = gfc_string_to_single_character
1569 (build_int_cst (integer_type_node, 1),
1570 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1572 ((*expr)->symtree->n.sym)),
1577 gfc_conv_variable (se, *expr);
1578 se->expr = gfc_string_to_single_character
1579 (build_int_cst (integer_type_node, 1),
1580 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1588 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1589 if STR is a string literal, otherwise return -1. */
1592 gfc_optimize_len_trim (tree len, tree str, int kind)
1595 && TREE_CODE (str) == ADDR_EXPR
1596 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1597 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1598 && array_ref_low_bound (TREE_OPERAND (str, 0))
1599 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1600 && TREE_INT_CST_LOW (len) >= 1
1601 && TREE_INT_CST_LOW (len)
1602 == (unsigned HOST_WIDE_INT)
1603 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1605 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1606 folded = build_fold_indirect_ref_loc (input_location, folded);
1607 if (TREE_CODE (folded) == INTEGER_CST)
1609 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1610 int length = TREE_STRING_LENGTH (string_cst);
1611 const char *ptr = TREE_STRING_POINTER (string_cst);
1613 for (; length > 0; length--)
1614 if (ptr[length - 1] != ' ')
1623 /* Compare two strings. If they are all single characters, the result is the
1624 subtraction of them. Otherwise, we build a library call. */
1627 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1628 enum tree_code code)
1634 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1635 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1637 sc1 = gfc_string_to_single_character (len1, str1, kind);
1638 sc2 = gfc_string_to_single_character (len2, str2, kind);
1640 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1642 /* Deal with single character specially. */
1643 sc1 = fold_convert (integer_type_node, sc1);
1644 sc2 = fold_convert (integer_type_node, sc2);
1645 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1649 if ((code == EQ_EXPR || code == NE_EXPR)
1651 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1653 /* If one string is a string literal with LEN_TRIM longer
1654 than the length of the second string, the strings
1656 int len = gfc_optimize_len_trim (len1, str1, kind);
1657 if (len > 0 && compare_tree_int (len2, len) < 0)
1658 return integer_one_node;
1659 len = gfc_optimize_len_trim (len2, str2, kind);
1660 if (len > 0 && compare_tree_int (len1, len) < 0)
1661 return integer_one_node;
1664 /* Build a call for the comparison. */
1666 fndecl = gfor_fndecl_compare_string;
1668 fndecl = gfor_fndecl_compare_string_char4;
1672 return build_call_expr_loc (input_location, fndecl, 4,
1673 len1, str1, len2, str2);
1677 /* Return the backend_decl for a procedure pointer component. */
1680 get_proc_ptr_comp (gfc_expr *e)
1686 gfc_init_se (&comp_se, NULL);
1687 e2 = gfc_copy_expr (e);
1688 /* We have to restore the expr type later so that gfc_free_expr frees
1689 the exact same thing that was allocated.
1690 TODO: This is ugly. */
1691 old_type = e2->expr_type;
1692 e2->expr_type = EXPR_VARIABLE;
1693 gfc_conv_expr (&comp_se, e2);
1694 e2->expr_type = old_type;
1696 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1701 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1705 if (gfc_is_proc_ptr_comp (expr, NULL))
1706 tmp = get_proc_ptr_comp (expr);
1707 else if (sym->attr.dummy)
1709 tmp = gfc_get_symbol_decl (sym);
1710 if (sym->attr.proc_pointer)
1711 tmp = build_fold_indirect_ref_loc (input_location,
1713 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1714 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1718 if (!sym->backend_decl)
1719 sym->backend_decl = gfc_get_extern_function_decl (sym);
1721 tmp = sym->backend_decl;
1723 if (sym->attr.cray_pointee)
1725 /* TODO - make the cray pointee a pointer to a procedure,
1726 assign the pointer to it and use it for the call. This
1728 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1729 gfc_get_symbol_decl (sym->cp_pointer));
1730 tmp = gfc_evaluate_now (tmp, &se->pre);
1733 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1735 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1736 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1743 /* Initialize MAPPING. */
1746 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1748 mapping->syms = NULL;
1749 mapping->charlens = NULL;
1753 /* Free all memory held by MAPPING (but not MAPPING itself). */
1756 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1758 gfc_interface_sym_mapping *sym;
1759 gfc_interface_sym_mapping *nextsym;
1761 gfc_charlen *nextcl;
1763 for (sym = mapping->syms; sym; sym = nextsym)
1765 nextsym = sym->next;
1766 sym->new_sym->n.sym->formal = NULL;
1767 gfc_free_symbol (sym->new_sym->n.sym);
1768 gfc_free_expr (sym->expr);
1769 free (sym->new_sym);
1772 for (cl = mapping->charlens; cl; cl = nextcl)
1775 gfc_free_expr (cl->length);
1781 /* Return a copy of gfc_charlen CL. Add the returned structure to
1782 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1784 static gfc_charlen *
1785 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1788 gfc_charlen *new_charlen;
1790 new_charlen = gfc_get_charlen ();
1791 new_charlen->next = mapping->charlens;
1792 new_charlen->length = gfc_copy_expr (cl->length);
1794 mapping->charlens = new_charlen;
1799 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1800 array variable that can be used as the actual argument for dummy
1801 argument SYM. Add any initialization code to BLOCK. PACKED is as
1802 for gfc_get_nodesc_array_type and DATA points to the first element
1803 in the passed array. */
1806 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1807 gfc_packed packed, tree data)
1812 type = gfc_typenode_for_spec (&sym->ts);
1813 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1814 !sym->attr.target && !sym->attr.pointer
1815 && !sym->attr.proc_pointer);
1817 var = gfc_create_var (type, "ifm");
1818 gfc_add_modify (block, var, fold_convert (type, data));
1824 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1825 and offset of descriptorless array type TYPE given that it has the same
1826 size as DESC. Add any set-up code to BLOCK. */
1829 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1836 offset = gfc_index_zero_node;
1837 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1839 dim = gfc_rank_cst[n];
1840 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1841 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1843 GFC_TYPE_ARRAY_LBOUND (type, n)
1844 = gfc_conv_descriptor_lbound_get (desc, dim);
1845 GFC_TYPE_ARRAY_UBOUND (type, n)
1846 = gfc_conv_descriptor_ubound_get (desc, dim);
1848 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1850 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1851 gfc_array_index_type,
1852 gfc_conv_descriptor_ubound_get (desc, dim),
1853 gfc_conv_descriptor_lbound_get (desc, dim));
1854 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1855 gfc_array_index_type,
1856 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1857 tmp = gfc_evaluate_now (tmp, block);
1858 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1860 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1861 GFC_TYPE_ARRAY_LBOUND (type, n),
1862 GFC_TYPE_ARRAY_STRIDE (type, n));
1863 offset = fold_build2_loc (input_location, MINUS_EXPR,
1864 gfc_array_index_type, offset, tmp);
1866 offset = gfc_evaluate_now (offset, block);
1867 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1871 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1872 in SE. The caller may still use se->expr and se->string_length after
1873 calling this function. */
1876 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1877 gfc_symbol * sym, gfc_se * se,
1880 gfc_interface_sym_mapping *sm;
1884 gfc_symbol *new_sym;
1886 gfc_symtree *new_symtree;
1888 /* Create a new symbol to represent the actual argument. */
1889 new_sym = gfc_new_symbol (sym->name, NULL);
1890 new_sym->ts = sym->ts;
1891 new_sym->as = gfc_copy_array_spec (sym->as);
1892 new_sym->attr.referenced = 1;
1893 new_sym->attr.dimension = sym->attr.dimension;
1894 new_sym->attr.contiguous = sym->attr.contiguous;
1895 new_sym->attr.codimension = sym->attr.codimension;
1896 new_sym->attr.pointer = sym->attr.pointer;
1897 new_sym->attr.allocatable = sym->attr.allocatable;
1898 new_sym->attr.flavor = sym->attr.flavor;
1899 new_sym->attr.function = sym->attr.function;
1901 /* Ensure that the interface is available and that
1902 descriptors are passed for array actual arguments. */
1903 if (sym->attr.flavor == FL_PROCEDURE)
1905 new_sym->formal = expr->symtree->n.sym->formal;
1906 new_sym->attr.always_explicit
1907 = expr->symtree->n.sym->attr.always_explicit;
1910 /* Create a fake symtree for it. */
1912 new_symtree = gfc_new_symtree (&root, sym->name);
1913 new_symtree->n.sym = new_sym;
1914 gcc_assert (new_symtree == root);
1916 /* Create a dummy->actual mapping. */
1917 sm = XCNEW (gfc_interface_sym_mapping);
1918 sm->next = mapping->syms;
1920 sm->new_sym = new_symtree;
1921 sm->expr = gfc_copy_expr (expr);
1924 /* Stabilize the argument's value. */
1925 if (!sym->attr.function && se)
1926 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1928 if (sym->ts.type == BT_CHARACTER)
1930 /* Create a copy of the dummy argument's length. */
1931 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1932 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1934 /* If the length is specified as "*", record the length that
1935 the caller is passing. We should use the callee's length
1936 in all other cases. */
1937 if (!new_sym->ts.u.cl->length && se)
1939 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1940 new_sym->ts.u.cl->backend_decl = se->string_length;
1947 /* Use the passed value as-is if the argument is a function. */
1948 if (sym->attr.flavor == FL_PROCEDURE)
1951 /* If the argument is either a string or a pointer to a string,
1952 convert it to a boundless character type. */
1953 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1955 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1956 tmp = build_pointer_type (tmp);
1957 if (sym->attr.pointer)
1958 value = build_fold_indirect_ref_loc (input_location,
1962 value = fold_convert (tmp, value);
1965 /* If the argument is a scalar, a pointer to an array or an allocatable,
1967 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1968 value = build_fold_indirect_ref_loc (input_location,
1971 /* For character(*), use the actual argument's descriptor. */
1972 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1973 value = build_fold_indirect_ref_loc (input_location,
1976 /* If the argument is an array descriptor, use it to determine
1977 information about the actual argument's shape. */
1978 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1979 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1981 /* Get the actual argument's descriptor. */
1982 desc = build_fold_indirect_ref_loc (input_location,
1985 /* Create the replacement variable. */
1986 tmp = gfc_conv_descriptor_data_get (desc);
1987 value = gfc_get_interface_mapping_array (&se->pre, sym,
1990 /* Use DESC to work out the upper bounds, strides and offset. */
1991 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1994 /* Otherwise we have a packed array. */
1995 value = gfc_get_interface_mapping_array (&se->pre, sym,
1996 PACKED_FULL, se->expr);
1998 new_sym->backend_decl = value;
2002 /* Called once all dummy argument mappings have been added to MAPPING,
2003 but before the mapping is used to evaluate expressions. Pre-evaluate
2004 the length of each argument, adding any initialization code to PRE and
2005 any finalization code to POST. */
2008 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2009 stmtblock_t * pre, stmtblock_t * post)
2011 gfc_interface_sym_mapping *sym;
2015 for (sym = mapping->syms; sym; sym = sym->next)
2016 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2017 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2019 expr = sym->new_sym->n.sym->ts.u.cl->length;
2020 gfc_apply_interface_mapping_to_expr (mapping, expr);
2021 gfc_init_se (&se, NULL);
2022 gfc_conv_expr (&se, expr);
2023 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2024 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2025 gfc_add_block_to_block (pre, &se.pre);
2026 gfc_add_block_to_block (post, &se.post);
2028 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2033 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2037 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2038 gfc_constructor_base base)
2041 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2043 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2046 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2047 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2048 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2054 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2058 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2063 for (; ref; ref = ref->next)
2067 for (n = 0; n < ref->u.ar.dimen; n++)
2069 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2070 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2071 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2073 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2080 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2081 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2087 /* Convert intrinsic function calls into result expressions. */
2090 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2098 arg1 = expr->value.function.actual->expr;
2099 if (expr->value.function.actual->next)
2100 arg2 = expr->value.function.actual->next->expr;
2104 sym = arg1->symtree->n.sym;
2106 if (sym->attr.dummy)
2111 switch (expr->value.function.isym->id)
2114 /* TODO figure out why this condition is necessary. */
2115 if (sym->attr.function
2116 && (arg1->ts.u.cl->length == NULL
2117 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2118 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2121 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2125 if (!sym->as || sym->as->rank == 0)
2128 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2130 dup = mpz_get_si (arg2->value.integer);
2135 dup = sym->as->rank;
2139 for (; d < dup; d++)
2143 if (!sym->as->upper[d] || !sym->as->lower[d])
2145 gfc_free_expr (new_expr);
2149 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2150 gfc_get_int_expr (gfc_default_integer_kind,
2152 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2154 new_expr = gfc_multiply (new_expr, tmp);
2160 case GFC_ISYM_LBOUND:
2161 case GFC_ISYM_UBOUND:
2162 /* TODO These implementations of lbound and ubound do not limit if
2163 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2165 if (!sym->as || sym->as->rank == 0)
2168 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2169 d = mpz_get_si (arg2->value.integer) - 1;
2171 /* TODO: If the need arises, this could produce an array of
2175 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2177 if (sym->as->lower[d])
2178 new_expr = gfc_copy_expr (sym->as->lower[d]);
2182 if (sym->as->upper[d])
2183 new_expr = gfc_copy_expr (sym->as->upper[d]);
2191 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2195 gfc_replace_expr (expr, new_expr);
2201 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2202 gfc_interface_mapping * mapping)
2204 gfc_formal_arglist *f;
2205 gfc_actual_arglist *actual;
2207 actual = expr->value.function.actual;
2208 f = map_expr->symtree->n.sym->formal;
2210 for (; f && actual; f = f->next, actual = actual->next)
2215 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2218 if (map_expr->symtree->n.sym->attr.dimension)
2223 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2225 for (d = 0; d < as->rank; d++)
2227 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2228 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2231 expr->value.function.esym->as = as;
2234 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2236 expr->value.function.esym->ts.u.cl->length
2237 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2239 gfc_apply_interface_mapping_to_expr (mapping,
2240 expr->value.function.esym->ts.u.cl->length);
2245 /* EXPR is a copy of an expression that appeared in the interface
2246 associated with MAPPING. Walk it recursively looking for references to
2247 dummy arguments that MAPPING maps to actual arguments. Replace each such
2248 reference with a reference to the associated actual argument. */
2251 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2254 gfc_interface_sym_mapping *sym;
2255 gfc_actual_arglist *actual;
2260 /* Copying an expression does not copy its length, so do that here. */
2261 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2263 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2264 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2267 /* Apply the mapping to any references. */
2268 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2270 /* ...and to the expression's symbol, if it has one. */
2271 /* TODO Find out why the condition on expr->symtree had to be moved into
2272 the loop rather than being outside it, as originally. */
2273 for (sym = mapping->syms; sym; sym = sym->next)
2274 if (expr->symtree && sym->old == expr->symtree->n.sym)
2276 if (sym->new_sym->n.sym->backend_decl)
2277 expr->symtree = sym->new_sym;
2279 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2280 /* Replace base type for polymorphic arguments. */
2281 if (expr->ref && expr->ref->type == REF_COMPONENT
2282 && sym->expr && sym->expr->ts.type == BT_CLASS)
2283 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2286 /* ...and to subexpressions in expr->value. */
2287 switch (expr->expr_type)
2292 case EXPR_SUBSTRING:
2296 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2297 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2301 for (actual = expr->value.function.actual; actual; actual = actual->next)
2302 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2304 if (expr->value.function.esym == NULL
2305 && expr->value.function.isym != NULL
2306 && expr->value.function.actual->expr->symtree
2307 && gfc_map_intrinsic_function (expr, mapping))
2310 for (sym = mapping->syms; sym; sym = sym->next)
2311 if (sym->old == expr->value.function.esym)
2313 expr->value.function.esym = sym->new_sym->n.sym;
2314 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2315 expr->value.function.esym->result = sym->new_sym->n.sym;
2320 case EXPR_STRUCTURE:
2321 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2334 /* Evaluate interface expression EXPR using MAPPING. Store the result
2338 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2339 gfc_se * se, gfc_expr * expr)
2341 expr = gfc_copy_expr (expr);
2342 gfc_apply_interface_mapping_to_expr (mapping, expr);
2343 gfc_conv_expr (se, expr);
2344 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2345 gfc_free_expr (expr);
2349 /* Returns a reference to a temporary array into which a component of
2350 an actual argument derived type array is copied and then returned
2351 after the function call. */
2353 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2354 sym_intent intent, bool formal_ptr)
2372 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2374 gfc_init_se (&lse, NULL);
2375 gfc_init_se (&rse, NULL);
2377 /* Walk the argument expression. */
2378 rss = gfc_walk_expr (expr);
2380 gcc_assert (rss != gfc_ss_terminator);
2382 /* Initialize the scalarizer. */
2383 gfc_init_loopinfo (&loop);
2384 gfc_add_ss_to_loop (&loop, rss);
2386 /* Calculate the bounds of the scalarization. */
2387 gfc_conv_ss_startstride (&loop);
2389 /* Build an ss for the temporary. */
2390 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2391 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2393 base_type = gfc_typenode_for_spec (&expr->ts);
2394 if (GFC_ARRAY_TYPE_P (base_type)
2395 || GFC_DESCRIPTOR_TYPE_P (base_type))
2396 base_type = gfc_get_element_type (base_type);
2398 loop.temp_ss = gfc_get_ss ();;
2399 loop.temp_ss->type = GFC_SS_TEMP;
2400 loop.temp_ss->data.temp.type = base_type;
2402 if (expr->ts.type == BT_CHARACTER)
2403 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2405 loop.temp_ss->string_length = NULL;
2407 parmse->string_length = loop.temp_ss->string_length;
2408 loop.temp_ss->data.temp.dimen = loop.dimen;
2409 loop.temp_ss->next = gfc_ss_terminator;
2411 /* Associate the SS with the loop. */
2412 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2414 /* Setup the scalarizing loops. */
2415 gfc_conv_loop_setup (&loop, &expr->where);
2417 /* Pass the temporary descriptor back to the caller. */
2418 info = &loop.temp_ss->data.info;
2419 parmse->expr = info->descriptor;
2421 /* Setup the gfc_se structures. */
2422 gfc_copy_loopinfo_to_se (&lse, &loop);
2423 gfc_copy_loopinfo_to_se (&rse, &loop);
2426 lse.ss = loop.temp_ss;
2427 gfc_mark_ss_chain_used (rss, 1);
2428 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2430 /* Start the scalarized loop body. */
2431 gfc_start_scalarized_body (&loop, &body);
2433 /* Translate the expression. */
2434 gfc_conv_expr (&rse, expr);
2436 gfc_conv_tmp_array_ref (&lse);
2438 if (intent != INTENT_OUT)
2440 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2441 gfc_add_expr_to_block (&body, tmp);
2442 gcc_assert (rse.ss == gfc_ss_terminator);
2443 gfc_trans_scalarizing_loops (&loop, &body);
2447 /* Make sure that the temporary declaration survives by merging
2448 all the loop declarations into the current context. */
2449 for (n = 0; n < loop.dimen; n++)
2451 gfc_merge_block_scope (&body);
2452 body = loop.code[loop.order[n]];
2454 gfc_merge_block_scope (&body);
2457 /* Add the post block after the second loop, so that any
2458 freeing of allocated memory is done at the right time. */
2459 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2461 /**********Copy the temporary back again.*********/
2463 gfc_init_se (&lse, NULL);
2464 gfc_init_se (&rse, NULL);
2466 /* Walk the argument expression. */
2467 lss = gfc_walk_expr (expr);
2468 rse.ss = loop.temp_ss;
2471 /* Initialize the scalarizer. */
2472 gfc_init_loopinfo (&loop2);
2473 gfc_add_ss_to_loop (&loop2, lss);
2475 /* Calculate the bounds of the scalarization. */
2476 gfc_conv_ss_startstride (&loop2);
2478 /* Setup the scalarizing loops. */
2479 gfc_conv_loop_setup (&loop2, &expr->where);
2481 gfc_copy_loopinfo_to_se (&lse, &loop2);
2482 gfc_copy_loopinfo_to_se (&rse, &loop2);
2484 gfc_mark_ss_chain_used (lss, 1);
2485 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2487 /* Declare the variable to hold the temporary offset and start the
2488 scalarized loop body. */
2489 offset = gfc_create_var (gfc_array_index_type, NULL);
2490 gfc_start_scalarized_body (&loop2, &body);
2492 /* Build the offsets for the temporary from the loop variables. The
2493 temporary array has lbounds of zero and strides of one in all
2494 dimensions, so this is very simple. The offset is only computed
2495 outside the innermost loop, so the overall transfer could be
2496 optimized further. */
2497 info = &rse.ss->data.info;
2498 dimen = info->dimen;
2500 tmp_index = gfc_index_zero_node;
2501 for (n = dimen - 1; n > 0; n--)
2504 tmp = rse.loop->loopvar[n];
2505 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2506 tmp, rse.loop->from[n]);
2507 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2510 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2511 gfc_array_index_type,
2512 rse.loop->to[n-1], rse.loop->from[n-1]);
2513 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2514 gfc_array_index_type,
2515 tmp_str, gfc_index_one_node);
2517 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2518 gfc_array_index_type, tmp, tmp_str);
2521 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2522 gfc_array_index_type,
2523 tmp_index, rse.loop->from[0]);
2524 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2526 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2527 gfc_array_index_type,
2528 rse.loop->loopvar[0], offset);
2530 /* Now use the offset for the reference. */
2531 tmp = build_fold_indirect_ref_loc (input_location,
2533 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2535 if (expr->ts.type == BT_CHARACTER)
2536 rse.string_length = expr->ts.u.cl->backend_decl;
2538 gfc_conv_expr (&lse, expr);
2540 gcc_assert (lse.ss == gfc_ss_terminator);
2542 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2543 gfc_add_expr_to_block (&body, tmp);
2545 /* Generate the copying loops. */
2546 gfc_trans_scalarizing_loops (&loop2, &body);
2548 /* Wrap the whole thing up by adding the second loop to the post-block
2549 and following it by the post-block of the first loop. In this way,
2550 if the temporary needs freeing, it is done after use! */
2551 if (intent != INTENT_IN)
2553 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2554 gfc_add_block_to_block (&parmse->post, &loop2.post);
2557 gfc_add_block_to_block (&parmse->post, &loop.post);
2559 gfc_cleanup_loop (&loop);
2560 gfc_cleanup_loop (&loop2);
2562 /* Pass the string length to the argument expression. */
2563 if (expr->ts.type == BT_CHARACTER)
2564 parmse->string_length = expr->ts.u.cl->backend_decl;
2566 /* Determine the offset for pointer formal arguments and set the
2570 size = gfc_index_one_node;
2571 offset = gfc_index_zero_node;
2572 for (n = 0; n < dimen; n++)
2574 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2576 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2577 gfc_array_index_type, tmp,
2578 gfc_index_one_node);
2579 gfc_conv_descriptor_ubound_set (&parmse->pre,
2583 gfc_conv_descriptor_lbound_set (&parmse->pre,
2586 gfc_index_one_node);
2587 size = gfc_evaluate_now (size, &parmse->pre);
2588 offset = fold_build2_loc (input_location, MINUS_EXPR,
2589 gfc_array_index_type,
2591 offset = gfc_evaluate_now (offset, &parmse->pre);
2592 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2593 gfc_array_index_type,
2594 rse.loop->to[n], rse.loop->from[n]);
2595 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2596 gfc_array_index_type,
2597 tmp, gfc_index_one_node);
2598 size = fold_build2_loc (input_location, MULT_EXPR,
2599 gfc_array_index_type, size, tmp);
2602 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2606 /* We want either the address for the data or the address of the descriptor,
2607 depending on the mode of passing array arguments. */
2609 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2611 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2617 /* Generate the code for argument list functions. */
2620 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2622 /* Pass by value for g77 %VAL(arg), pass the address
2623 indirectly for %LOC, else by reference. Thus %REF
2624 is a "do-nothing" and %LOC is the same as an F95
2626 if (strncmp (name, "%VAL", 4) == 0)
2627 gfc_conv_expr (se, expr);
2628 else if (strncmp (name, "%LOC", 4) == 0)
2630 gfc_conv_expr_reference (se, expr);
2631 se->expr = gfc_build_addr_expr (NULL, se->expr);
2633 else if (strncmp (name, "%REF", 4) == 0)
2634 gfc_conv_expr_reference (se, expr);
2636 gfc_error ("Unknown argument list function at %L", &expr->where);
2640 /* Takes a derived type expression and returns the address of a temporary
2641 class object of the 'declared' type. */
2643 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2644 gfc_typespec class_ts)
2648 gfc_symbol *declared = class_ts.u.derived;
2654 /* The derived type needs to be converted to a temporary
2656 tmp = gfc_typenode_for_spec (&class_ts);
2657 var = gfc_create_var (tmp, "class");
2660 cmp = gfc_find_component (declared, "_vptr", true, true);
2661 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2662 TREE_TYPE (cmp->backend_decl),
2663 var, cmp->backend_decl, NULL_TREE);
2665 /* Remember the vtab corresponds to the derived type
2666 not to the class declared type. */
2667 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2669 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2670 gfc_add_modify (&parmse->pre, ctree,
2671 fold_convert (TREE_TYPE (ctree), tmp));
2673 /* Now set the data field. */
2674 cmp = gfc_find_component (declared, "_data", true, true);
2675 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2676 TREE_TYPE (cmp->backend_decl),
2677 var, cmp->backend_decl, NULL_TREE);
2678 ss = gfc_walk_expr (e);
2679 if (ss == gfc_ss_terminator)
2682 gfc_conv_expr_reference (parmse, e);
2683 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2684 gfc_add_modify (&parmse->pre, ctree, tmp);
2689 gfc_conv_expr (parmse, e);
2690 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2693 /* Pass the address of the class object. */
2694 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2698 /* The following routine generates code for the intrinsic
2699 procedures from the ISO_C_BINDING module:
2701 * C_FUNLOC (function)
2702 * C_F_POINTER (subroutine)
2703 * C_F_PROCPOINTER (subroutine)
2704 * C_ASSOCIATED (function)
2705 One exception which is not handled here is C_F_POINTER with non-scalar
2706 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2709 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2710 gfc_actual_arglist * arg)
2715 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2717 if (arg->expr->rank == 0)
2718 gfc_conv_expr_reference (se, arg->expr);
2722 /* This is really the actual arg because no formal arglist is
2723 created for C_LOC. */
2724 fsym = arg->expr->symtree->n.sym;
2726 /* We should want it to do g77 calling convention. */
2728 && !(fsym->attr.pointer || fsym->attr.allocatable)
2729 && fsym->as->type != AS_ASSUMED_SHAPE;
2730 f = f || !sym->attr.always_explicit;
2732 argss = gfc_walk_expr (arg->expr);
2733 gfc_conv_array_parameter (se, arg->expr, argss, f,
2737 /* TODO -- the following two lines shouldn't be necessary, but if
2738 they're removed, a bug is exposed later in the code path.
2739 This workaround was thus introduced, but will have to be
2740 removed; please see PR 35150 for details about the issue. */
2741 se->expr = convert (pvoid_type_node, se->expr);
2742 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2746 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2748 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2749 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2750 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2751 gfc_conv_expr_reference (se, arg->expr);
2755 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2756 && arg->next->expr->rank == 0)
2757 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2759 /* Convert c_f_pointer if fptr is a scalar
2760 and convert c_f_procpointer. */
2764 gfc_init_se (&cptrse, NULL);
2765 gfc_conv_expr (&cptrse, arg->expr);
2766 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2767 gfc_add_block_to_block (&se->post, &cptrse.post);
2769 gfc_init_se (&fptrse, NULL);
2770 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2771 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2772 fptrse.want_pointer = 1;
2774 gfc_conv_expr (&fptrse, arg->next->expr);
2775 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2776 gfc_add_block_to_block (&se->post, &fptrse.post);
2778 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2779 && arg->next->expr->symtree->n.sym->attr.dummy)
2780 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2783 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2784 TREE_TYPE (fptrse.expr),
2786 fold_convert (TREE_TYPE (fptrse.expr),
2791 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2796 /* Build the addr_expr for the first argument. The argument is
2797 already an *address* so we don't need to set want_pointer in
2799 gfc_init_se (&arg1se, NULL);
2800 gfc_conv_expr (&arg1se, arg->expr);
2801 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2802 gfc_add_block_to_block (&se->post, &arg1se.post);
2804 /* See if we were given two arguments. */
2805 if (arg->next == NULL)
2806 /* Only given one arg so generate a null and do a
2807 not-equal comparison against the first arg. */
2808 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2810 fold_convert (TREE_TYPE (arg1se.expr),
2811 null_pointer_node));
2817 /* Given two arguments so build the arg2se from second arg. */
2818 gfc_init_se (&arg2se, NULL);
2819 gfc_conv_expr (&arg2se, arg->next->expr);
2820 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2821 gfc_add_block_to_block (&se->post, &arg2se.post);
2823 /* Generate test to compare that the two args are equal. */
2824 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2825 arg1se.expr, arg2se.expr);
2826 /* Generate test to ensure that the first arg is not null. */
2827 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2829 arg1se.expr, null_pointer_node);
2831 /* Finally, the generated test must check that both arg1 is not
2832 NULL and that it is equal to the second arg. */
2833 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2835 not_null_expr, eq_expr);
2841 /* Nothing was done. */
2846 /* Generate code for a procedure call. Note can return se->post != NULL.
2847 If se->direct_byref is set then se->expr contains the return parameter.
2848 Return nonzero, if the call has alternate specifiers.
2849 'expr' is only needed for procedure pointer components. */
2852 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2853 gfc_actual_arglist * args, gfc_expr * expr,
2854 VEC(tree,gc) *append_args)
2856 gfc_interface_mapping mapping;
2857 VEC(tree,gc) *arglist;
2858 VEC(tree,gc) *retargs;
2869 VEC(tree,gc) *stringargs;
2871 gfc_formal_arglist *formal;
2872 gfc_actual_arglist *arg;
2873 int has_alternate_specifier = 0;
2874 bool need_interface_mapping;
2881 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2882 gfc_component *comp = NULL;
2892 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2893 && conv_isocbinding_procedure (se, sym, args))
2896 gfc_is_proc_ptr_comp (expr, &comp);
2900 if (!sym->attr.elemental)
2902 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2903 if (se->ss->useflags)
2905 gcc_assert ((!comp && gfc_return_by_reference (sym)
2906 && sym->result->attr.dimension)
2907 || (comp && comp->attr.dimension));
2908 gcc_assert (se->loop != NULL);
2910 /* Access the previously obtained result. */
2911 gfc_conv_tmp_array_ref (se);
2915 info = &se->ss->data.info;
2920 gfc_init_block (&post);
2921 gfc_init_interface_mapping (&mapping);
2924 formal = sym->formal;
2925 need_interface_mapping = sym->attr.dimension ||
2926 (sym->ts.type == BT_CHARACTER
2927 && sym->ts.u.cl->length
2928 && sym->ts.u.cl->length->expr_type
2933 formal = comp->formal;
2934 need_interface_mapping = comp->attr.dimension ||
2935 (comp->ts.type == BT_CHARACTER
2936 && comp->ts.u.cl->length
2937 && comp->ts.u.cl->length->expr_type
2941 /* Evaluate the arguments. */
2942 for (arg = args; arg != NULL;
2943 arg = arg->next, formal = formal ? formal->next : NULL)
2946 fsym = formal ? formal->sym : NULL;
2947 parm_kind = MISSING;
2951 if (se->ignore_optional)
2953 /* Some intrinsics have already been resolved to the correct
2957 else if (arg->label)
2959 has_alternate_specifier = 1;
2964 /* Pass a NULL pointer for an absent arg. */
2965 gfc_init_se (&parmse, NULL);
2966 parmse.expr = null_pointer_node;
2967 if (arg->missing_arg_type == BT_CHARACTER)
2968 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2971 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2973 /* Pass a NULL pointer to denote an absent arg. */
2974 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2975 gfc_init_se (&parmse, NULL);
2976 parmse.expr = null_pointer_node;
2977 if (arg->missing_arg_type == BT_CHARACTER)
2978 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2980 else if (fsym && fsym->ts.type == BT_CLASS
2981 && e->ts.type == BT_DERIVED)
2983 /* The derived type needs to be converted to a temporary
2985 gfc_init_se (&parmse, se);
2986 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2988 else if (se->ss && se->ss->useflags)
2990 /* An elemental function inside a scalarized loop. */
2991 gfc_init_se (&parmse, se);
2992 gfc_conv_expr_reference (&parmse, e);
2993 parm_kind = ELEMENTAL;
2997 /* A scalar or transformational function. */
2998 gfc_init_se (&parmse, NULL);
2999 argss = gfc_walk_expr (e);
3001 if (argss == gfc_ss_terminator)
3003 if (e->expr_type == EXPR_VARIABLE
3004 && e->symtree->n.sym->attr.cray_pointee
3005 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3007 /* The Cray pointer needs to be converted to a pointer to
3008 a type given by the expression. */
3009 gfc_conv_expr (&parmse, e);
3010 type = build_pointer_type (TREE_TYPE (parmse.expr));
3011 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3012 parmse.expr = convert (type, tmp);
3014 else if (fsym && fsym->attr.value)
3016 if (fsym->ts.type == BT_CHARACTER
3017 && fsym->ts.is_c_interop
3018 && fsym->ns->proc_name != NULL
3019 && fsym->ns->proc_name->attr.is_bind_c)
3022 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3023 if (parmse.expr == NULL)
3024 gfc_conv_expr (&parmse, e);
3027 gfc_conv_expr (&parmse, e);
3029 else if (arg->name && arg->name[0] == '%')
3030 /* Argument list functions %VAL, %LOC and %REF are signalled
3031 through arg->name. */
3032 conv_arglist_function (&parmse, arg->expr, arg->name);
3033 else if ((e->expr_type == EXPR_FUNCTION)
3034 && ((e->value.function.esym
3035 && e->value.function.esym->result->attr.pointer)
3036 || (!e->value.function.esym
3037 && e->symtree->n.sym->attr.pointer))
3038 && fsym && fsym->attr.target)
3040 gfc_conv_expr (&parmse, e);
3041 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3043 else if (e->expr_type == EXPR_FUNCTION
3044 && e->symtree->n.sym->result
3045 && e->symtree->n.sym->result != e->symtree->n.sym
3046 && e->symtree->n.sym->result->attr.proc_pointer)
3048 /* Functions returning procedure pointers. */
3049 gfc_conv_expr (&parmse, e);
3050 if (fsym && fsym->attr.proc_pointer)
3051 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3055 gfc_conv_expr_reference (&parmse, e);
3057 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3058 allocated on entry, it must be deallocated. */
3059 if (fsym && fsym->attr.allocatable
3060 && fsym->attr.intent == INTENT_OUT)
3064 gfc_init_block (&block);
3065 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3067 gfc_add_expr_to_block (&block, tmp);
3068 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3069 void_type_node, parmse.expr,
3071 gfc_add_expr_to_block (&block, tmp);
3073 if (fsym->attr.optional
3074 && e->expr_type == EXPR_VARIABLE
3075 && e->symtree->n.sym->attr.optional)
3077 tmp = fold_build3_loc (input_location, COND_EXPR,
3079 gfc_conv_expr_present (e->symtree->n.sym),
3080 gfc_finish_block (&block),
3081 build_empty_stmt (input_location));
3084 tmp = gfc_finish_block (&block);
3086 gfc_add_expr_to_block (&se->pre, tmp);
3089 if (fsym && e->expr_type != EXPR_NULL
3090 && ((fsym->attr.pointer
3091 && fsym->attr.flavor != FL_PROCEDURE)
3092 || (fsym->attr.proc_pointer
3093 && !(e->expr_type == EXPR_VARIABLE
3094 && e->symtree->n.sym->attr.dummy))
3095 || (fsym->attr.proc_pointer
3096 && e->expr_type == EXPR_VARIABLE
3097 && gfc_is_proc_ptr_comp (e, NULL))
3098 || fsym->attr.allocatable))
3100 /* Scalar pointer dummy args require an extra level of
3101 indirection. The null pointer already contains
3102 this level of indirection. */
3103 parm_kind = SCALAR_POINTER;
3104 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3110 /* If the procedure requires an explicit interface, the actual
3111 argument is passed according to the corresponding formal
3112 argument. If the corresponding formal argument is a POINTER,
3113 ALLOCATABLE or assumed shape, we do not use g77's calling
3114 convention, and pass the address of the array descriptor
3115 instead. Otherwise we use g77's calling convention. */
3118 && !(fsym->attr.pointer || fsym->attr.allocatable)
3119 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3121 f = f || !comp->attr.always_explicit;
3123 f = f || !sym->attr.always_explicit;
3125 /* If the argument is a function call that may not create
3126 a temporary for the result, we have to check that we
3127 can do it, i.e. that there is no alias between this
3128 argument and another one. */
3129 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3135 intent = fsym->attr.intent;
3137 intent = INTENT_UNKNOWN;
3139 if (gfc_check_fncall_dependency (e, intent, sym, args,
3141 parmse.force_tmp = 1;
3143 iarg = e->value.function.actual->expr;
3145 /* Temporary needed if aliasing due to host association. */
3146 if (sym->attr.contained
3148 && !sym->attr.implicit_pure
3149 && !sym->attr.use_assoc
3150 && iarg->expr_type == EXPR_VARIABLE
3151 && sym->ns == iarg->symtree->n.sym->ns)
3152 parmse.force_tmp = 1;
3154 /* Ditto within module. */
3155 if (sym->attr.use_assoc
3157 && !sym->attr.implicit_pure
3158 && iarg->expr_type == EXPR_VARIABLE
3159 && sym->module == iarg->symtree->n.sym->module)
3160 parmse.force_tmp = 1;
3163 if (e->expr_type == EXPR_VARIABLE
3164 && is_subref_array (e))
3165 /* The actual argument is a component reference to an
3166 array of derived types. In this case, the argument
3167 is converted to a temporary, which is passed and then
3168 written back after the procedure call. */
3169 gfc_conv_subref_array_arg (&parmse, e, f,
3170 fsym ? fsym->attr.intent : INTENT_INOUT,
3171 fsym && fsym->attr.pointer);
3173 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3176 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3177 allocated on entry, it must be deallocated. */
3178 if (fsym && fsym->attr.allocatable
3179 && fsym->attr.intent == INTENT_OUT)
3181 tmp = build_fold_indirect_ref_loc (input_location,
3183 tmp = gfc_trans_dealloc_allocated (tmp);
3184 if (fsym->attr.optional
3185 && e->expr_type == EXPR_VARIABLE
3186 && e->symtree->n.sym->attr.optional)
3187 tmp = fold_build3_loc (input_location, COND_EXPR,
3189 gfc_conv_expr_present (e->symtree->n.sym),
3190 tmp, build_empty_stmt (input_location));
3191 gfc_add_expr_to_block (&se->pre, tmp);
3196 /* The case with fsym->attr.optional is that of a user subroutine
3197 with an interface indicating an optional argument. When we call
3198 an intrinsic subroutine, however, fsym is NULL, but we might still
3199 have an optional argument, so we proceed to the substitution
3201 if (e && (fsym == NULL || fsym->attr.optional))
3203 /* If an optional argument is itself an optional dummy argument,
3204 check its presence and substitute a null if absent. This is
3205 only needed when passing an array to an elemental procedure
3206 as then array elements are accessed - or no NULL pointer is
3207 allowed and a "1" or "0" should be passed if not present.
3208 When passing a non-array-descriptor full array to a
3209 non-array-descriptor dummy, no check is needed. For
3210 array-descriptor actual to array-descriptor dummy, see
3211 PR 41911 for why a check has to be inserted.
3212 fsym == NULL is checked as intrinsics required the descriptor
3213 but do not always set fsym. */
3214 if (e->expr_type == EXPR_VARIABLE
3215 && e->symtree->n.sym->attr.optional
3216 && ((e->rank > 0 && sym->attr.elemental)
3217 || e->representation.length || e->ts.type == BT_CHARACTER
3221 && (fsym->as->type == AS_ASSUMED_SHAPE
3222 || fsym->as->type == AS_DEFERRED))))))
3223 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3224 e->representation.length);
3229 /* Obtain the character length of an assumed character length
3230 length procedure from the typespec. */
3231 if (fsym->ts.type == BT_CHARACTER
3232 && parmse.string_length == NULL_TREE
3233 && e->ts.type == BT_PROCEDURE
3234 && e->symtree->n.sym->ts.type == BT_CHARACTER
3235 && e->symtree->n.sym->ts.u.cl->length != NULL
3236 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3238 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3239 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3243 if (fsym && need_interface_mapping && e)
3244 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3246 gfc_add_block_to_block (&se->pre, &parmse.pre);
3247 gfc_add_block_to_block (&post, &parmse.post);
3249 /* Allocated allocatable components of derived types must be
3250 deallocated for non-variable scalars. Non-variable arrays are
3251 dealt with in trans-array.c(gfc_conv_array_parameter). */
3252 if (e && e->ts.type == BT_DERIVED
3253 && e->ts.u.derived->attr.alloc_comp
3254 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3255 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3258 tmp = build_fold_indirect_ref_loc (input_location,
3260 parm_rank = e->rank;
3268 case (SCALAR_POINTER):
3269 tmp = build_fold_indirect_ref_loc (input_location,
3274 if (e->expr_type == EXPR_OP
3275 && e->value.op.op == INTRINSIC_PARENTHESES
3276 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3279 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3280 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3281 gfc_add_expr_to_block (&se->post, local_tmp);
3284 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3286 gfc_add_expr_to_block (&se->post, tmp);
3289 /* Add argument checking of passing an unallocated/NULL actual to
3290 a nonallocatable/nonpointer dummy. */
3292 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3294 symbol_attribute attr;
3298 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3299 attr = gfc_expr_attr (e);
3301 goto end_pointer_check;
3303 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3304 allocatable to an optional dummy, cf. 12.5.2.12. */
3305 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3306 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3307 goto end_pointer_check;
3311 /* If the actual argument is an optional pointer/allocatable and
3312 the formal argument takes an nonpointer optional value,
3313 it is invalid to pass a non-present argument on, even
3314 though there is no technical reason for this in gfortran.
3315 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3316 tree present, null_ptr, type;
3318 if (attr.allocatable
3319 && (fsym == NULL || !fsym->attr.allocatable))
3320 asprintf (&msg, "Allocatable actual argument '%s' is not "
3321 "allocated or not present", e->symtree->n.sym->name);
3322 else if (attr.pointer
3323 && (fsym == NULL || !fsym->attr.pointer))
3324 asprintf (&msg, "Pointer actual argument '%s' is not "
3325 "associated or not present",
3326 e->symtree->n.sym->name);
3327 else if (attr.proc_pointer
3328 && (fsym == NULL || !fsym->attr.proc_pointer))
3329 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3330 "associated or not present",
3331 e->symtree->n.sym->name);
3333 goto end_pointer_check;
3335 present = gfc_conv_expr_present (e->symtree->n.sym);
3336 type = TREE_TYPE (present);
3337 present = fold_build2_loc (input_location, EQ_EXPR,
3338 boolean_type_node, present,
3340 null_pointer_node));
3341 type = TREE_TYPE (parmse.expr);
3342 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3343 boolean_type_node, parmse.expr,
3345 null_pointer_node));
3346 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3347 boolean_type_node, present, null_ptr);
3351 if (attr.allocatable
3352 && (fsym == NULL || !fsym->attr.allocatable))
3353 asprintf (&msg, "Allocatable actual argument '%s' is not "
3354 "allocated", e->symtree->n.sym->name);
3355 else if (attr.pointer
3356 && (fsym == NULL || !fsym->attr.pointer))
3357 asprintf (&msg, "Pointer actual argument '%s' is not "
3358 "associated", e->symtree->n.sym->name);
3359 else if (attr.proc_pointer
3360 && (fsym == NULL || !fsym->attr.proc_pointer))
3361 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3362 "associated", e->symtree->n.sym->name);
3364 goto end_pointer_check;
3367 cond = fold_build2_loc (input_location, EQ_EXPR,
3368 boolean_type_node, parmse.expr,
3369 fold_convert (TREE_TYPE (parmse.expr),
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 info->dimen = se->loop->dimen;
3587 /* Evaluate the bounds of the result, if known. */
3588 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3590 /* If the lhs of an assignment x = f(..) is allocatable and
3591 f2003 is allowed, we must not generate the function call
3592 here but should just send back the results of the mapping.
3593 This is signalled by the function ss being flagged. */
3594 if (gfc_option.flag_realloc_lhs
3595 && se->ss && se->ss->is_alloc_lhs)
3597 gfc_free_interface_mapping (&mapping);
3598 return has_alternate_specifier;
3601 /* Create a temporary to store the result. In case the function
3602 returns a pointer, the temporary will be a shallow copy and
3603 mustn't be deallocated. */
3604 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3605 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3606 NULL_TREE, false, !comp->attr.pointer,
3607 callee_alloc, &se->ss->expr->where);
3609 /* Pass the temporary as the first argument. */
3610 result = info->descriptor;
3611 tmp = gfc_build_addr_expr (NULL_TREE, result);
3612 VEC_safe_push (tree, gc, retargs, tmp);
3614 else if (!comp && sym->result->attr.dimension)
3616 gcc_assert (se->loop && info);
3618 /* Set the type of the array. */
3619 tmp = gfc_typenode_for_spec (&ts);
3620 info->dimen = se->loop->dimen;
3622 /* Evaluate the bounds of the result, if known. */
3623 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3625 /* If the lhs of an assignment x = f(..) is allocatable and
3626 f2003 is allowed, we must not generate the function call
3627 here but should just send back the results of the mapping.
3628 This is signalled by the function ss being flagged. */
3629 if (gfc_option.flag_realloc_lhs
3630 && se->ss && se->ss->is_alloc_lhs)
3632 gfc_free_interface_mapping (&mapping);
3633 return has_alternate_specifier;
3636 /* Create a temporary to store the result. In case the function
3637 returns a pointer, the temporary will be a shallow copy and
3638 mustn't be deallocated. */
3639 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3640 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3641 NULL_TREE, false, !sym->attr.pointer,
3642 callee_alloc, &se->ss->expr->where);
3644 /* Pass the temporary as the first argument. */
3645 result = info->descriptor;
3646 tmp = gfc_build_addr_expr (NULL_TREE, result);
3647 VEC_safe_push (tree, gc, retargs, tmp);
3649 else if (ts.type == BT_CHARACTER)
3651 /* Pass the string length. */
3652 type = gfc_get_character_type (ts.kind, ts.u.cl);
3653 type = build_pointer_type (type);
3655 /* Return an address to a char[0:len-1]* temporary for
3656 character pointers. */
3657 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3658 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3660 var = gfc_create_var (type, "pstr");
3662 if ((!comp && sym->attr.allocatable)
3663 || (comp && comp->attr.allocatable))
3664 gfc_add_modify (&se->pre, var,
3665 fold_convert (TREE_TYPE (var),
3666 null_pointer_node));
3668 /* Provide an address expression for the function arguments. */
3669 var = gfc_build_addr_expr (NULL_TREE, var);
3672 var = gfc_conv_string_tmp (se, type, len);
3674 VEC_safe_push (tree, gc, retargs, var);
3678 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3680 type = gfc_get_complex_type (ts.kind);
3681 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3682 VEC_safe_push (tree, gc, retargs, var);
3685 if (ts.type == BT_CHARACTER && ts.deferred
3686 && (sym->attr.allocatable || sym->attr.pointer))
3689 if (TREE_CODE (tmp) != VAR_DECL)
3690 tmp = gfc_evaluate_now (len, &se->pre);
3691 len = gfc_build_addr_expr (NULL_TREE, tmp);
3694 /* Add the string length to the argument list. */
3695 if (ts.type == BT_CHARACTER)
3696 VEC_safe_push (tree, gc, retargs, len);
3698 gfc_free_interface_mapping (&mapping);
3700 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3701 arglen = (VEC_length (tree, arglist)
3702 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3703 VEC_reserve_exact (tree, gc, retargs, arglen);
3705 /* Add the return arguments. */
3706 VEC_splice (tree, retargs, arglist);
3708 /* Add the hidden string length parameters to the arguments. */
3709 VEC_splice (tree, retargs, stringargs);
3711 /* We may want to append extra arguments here. This is used e.g. for
3712 calls to libgfortran_matmul_??, which need extra information. */
3713 if (!VEC_empty (tree, append_args))
3714 VEC_splice (tree, retargs, append_args);
3717 /* Generate the actual call. */
3718 conv_function_val (se, sym, expr);
3720 /* If there are alternate return labels, function type should be
3721 integer. Can't modify the type in place though, since it can be shared
3722 with other functions. For dummy arguments, the typing is done to
3723 this result, even if it has to be repeated for each call. */
3724 if (has_alternate_specifier
3725 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3727 if (!sym->attr.dummy)
3729 TREE_TYPE (sym->backend_decl)
3730 = build_function_type (integer_type_node,
3731 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3732 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3735 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3738 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3739 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3741 /* If we have a pointer function, but we don't want a pointer, e.g.
3744 where f is pointer valued, we have to dereference the result. */
3745 if (!se->want_pointer && !byref
3746 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3747 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3748 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3750 /* f2c calling conventions require a scalar default real function to
3751 return a double precision result. Convert this back to default
3752 real. We only care about the cases that can happen in Fortran 77.
3754 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3755 && sym->ts.kind == gfc_default_real_kind
3756 && !sym->attr.always_explicit)
3757 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3759 /* A pure function may still have side-effects - it may modify its
3761 TREE_SIDE_EFFECTS (se->expr) = 1;
3763 if (!sym->attr.pure)
3764 TREE_SIDE_EFFECTS (se->expr) = 1;
3769 /* Add the function call to the pre chain. There is no expression. */
3770 gfc_add_expr_to_block (&se->pre, se->expr);
3771 se->expr = NULL_TREE;
3773 if (!se->direct_byref)
3775 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3777 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3779 /* Check the data pointer hasn't been modified. This would
3780 happen in a function returning a pointer. */
3781 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3782 tmp = fold_build2_loc (input_location, NE_EXPR,
3785 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3788 se->expr = info->descriptor;
3789 /* Bundle in the string length. */
3790 se->string_length = len;
3792 else if (ts.type == BT_CHARACTER)
3794 /* Dereference for character pointer results. */
3795 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3796 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3797 se->expr = build_fold_indirect_ref_loc (input_location, var);
3802 se->string_length = len;
3803 else if (sym->attr.allocatable || sym->attr.pointer)
3804 se->string_length = cl.backend_decl;
3808 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3809 se->expr = build_fold_indirect_ref_loc (input_location, var);
3814 /* Follow the function call with the argument post block. */
3817 gfc_add_block_to_block (&se->pre, &post);
3819 /* Transformational functions of derived types with allocatable
3820 components must have the result allocatable components copied. */
3821 arg = expr->value.function.actual;
3822 if (result && arg && expr->rank
3823 && expr->value.function.isym
3824 && expr->value.function.isym->transformational
3825 && arg->expr->ts.type == BT_DERIVED
3826 && arg->expr->ts.u.derived->attr.alloc_comp)
3829 /* Copy the allocatable components. We have to use a
3830 temporary here to prevent source allocatable components
3831 from being corrupted. */
3832 tmp2 = gfc_evaluate_now (result, &se->pre);
3833 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3834 result, tmp2, expr->rank);
3835 gfc_add_expr_to_block (&se->pre, tmp);
3836 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3838 gfc_add_expr_to_block (&se->pre, tmp);
3840 /* Finally free the temporary's data field. */
3841 tmp = gfc_conv_descriptor_data_get (tmp2);
3842 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3843 gfc_add_expr_to_block (&se->pre, tmp);
3847 gfc_add_block_to_block (&se->post, &post);
3849 return has_alternate_specifier;
3853 /* Fill a character string with spaces. */
3856 fill_with_spaces (tree start, tree type, tree size)
3858 stmtblock_t block, loop;
3859 tree i, el, exit_label, cond, tmp;
3861 /* For a simple char type, we can call memset(). */
3862 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3863 return build_call_expr_loc (input_location,
3864 built_in_decls[BUILT_IN_MEMSET], 3, start,
3865 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3866 lang_hooks.to_target_charset (' ')),
3869 /* Otherwise, we use a loop:
3870 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3874 /* Initialize variables. */
3875 gfc_init_block (&block);
3876 i = gfc_create_var (sizetype, "i");
3877 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3878 el = gfc_create_var (build_pointer_type (type), "el");
3879 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3880 exit_label = gfc_build_label_decl (NULL_TREE);
3881 TREE_USED (exit_label) = 1;
3885 gfc_init_block (&loop);
3887 /* Exit condition. */
3888 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3889 build_zero_cst (sizetype));
3890 tmp = build1_v (GOTO_EXPR, exit_label);
3891 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3892 build_empty_stmt (input_location));
3893 gfc_add_expr_to_block (&loop, tmp);
3896 gfc_add_modify (&loop,
3897 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3898 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3900 /* Increment loop variables. */
3901 gfc_add_modify (&loop, i,
3902 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3903 TYPE_SIZE_UNIT (type)));
3904 gfc_add_modify (&loop, el,
3905 fold_build_pointer_plus_loc (input_location,
3906 el, TYPE_SIZE_UNIT (type)));
3908 /* Making the loop... actually loop! */
3909 tmp = gfc_finish_block (&loop);
3910 tmp = build1_v (LOOP_EXPR, tmp);
3911 gfc_add_expr_to_block (&block, tmp);
3913 /* The exit label. */
3914 tmp = build1_v (LABEL_EXPR, exit_label);
3915 gfc_add_expr_to_block (&block, tmp);
3918 return gfc_finish_block (&block);
3922 /* Generate code to copy a string. */
3925 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3926 int dkind, tree slength, tree src, int skind)
3928 tree tmp, dlen, slen;
3937 stmtblock_t tempblock;
3939 gcc_assert (dkind == skind);
3941 if (slength != NULL_TREE)
3943 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3944 ssc = gfc_string_to_single_character (slen, src, skind);
3948 slen = build_int_cst (size_type_node, 1);
3952 if (dlength != NULL_TREE)
3954 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3955 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3959 dlen = build_int_cst (size_type_node, 1);
3963 /* Assign directly if the types are compatible. */
3964 if (dsc != NULL_TREE && ssc != NULL_TREE
3965 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3967 gfc_add_modify (block, dsc, ssc);
3971 /* Do nothing if the destination length is zero. */
3972 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3973 build_int_cst (size_type_node, 0));
3975 /* The following code was previously in _gfortran_copy_string:
3977 // The two strings may overlap so we use memmove.
3979 copy_string (GFC_INTEGER_4 destlen, char * dest,
3980 GFC_INTEGER_4 srclen, const char * src)
3982 if (srclen >= destlen)
3984 // This will truncate if too long.
3985 memmove (dest, src, destlen);
3989 memmove (dest, src, srclen);
3991 memset (&dest[srclen], ' ', destlen - srclen);
3995 We're now doing it here for better optimization, but the logic
3998 /* For non-default character kinds, we have to multiply the string
3999 length by the base type size. */
4000 chartype = gfc_get_char_type (dkind);
4001 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4002 fold_convert (size_type_node, slen),
4003 fold_convert (size_type_node,
4004 TYPE_SIZE_UNIT (chartype)));
4005 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4006 fold_convert (size_type_node, dlen),
4007 fold_convert (size_type_node,
4008 TYPE_SIZE_UNIT (chartype)));
4010 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4011 dest = fold_convert (pvoid_type_node, dest);
4013 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4015 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4016 src = fold_convert (pvoid_type_node, src);
4018 src = gfc_build_addr_expr (pvoid_type_node, src);
4020 /* Truncate string if source is too long. */
4021 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4023 tmp2 = build_call_expr_loc (input_location,
4024 built_in_decls[BUILT_IN_MEMMOVE],
4025 3, dest, src, dlen);
4027 /* Else copy and pad with spaces. */
4028 tmp3 = build_call_expr_loc (input_location,
4029 built_in_decls[BUILT_IN_MEMMOVE],
4030 3, dest, src, slen);
4032 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4033 tmp4 = fill_with_spaces (tmp4, chartype,
4034 fold_build2_loc (input_location, MINUS_EXPR,
4035 TREE_TYPE(dlen), dlen, slen));
4037 gfc_init_block (&tempblock);
4038 gfc_add_expr_to_block (&tempblock, tmp3);
4039 gfc_add_expr_to_block (&tempblock, tmp4);
4040 tmp3 = gfc_finish_block (&tempblock);
4042 /* The whole copy_string function is there. */
4043 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4045 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4046 build_empty_stmt (input_location));
4047 gfc_add_expr_to_block (block, tmp);
4051 /* Translate a statement function.
4052 The value of a statement function reference is obtained by evaluating the
4053 expression using the values of the actual arguments for the values of the
4054 corresponding dummy arguments. */
4057 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4061 gfc_formal_arglist *fargs;
4062 gfc_actual_arglist *args;
4065 gfc_saved_var *saved_vars;
4071 sym = expr->symtree->n.sym;
4072 args = expr->value.function.actual;
4073 gfc_init_se (&lse, NULL);
4074 gfc_init_se (&rse, NULL);
4077 for (fargs = sym->formal; fargs; fargs = fargs->next)
4079 saved_vars = XCNEWVEC (gfc_saved_var, n);
4080 temp_vars = XCNEWVEC (tree, n);
4082 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4084 /* Each dummy shall be specified, explicitly or implicitly, to be
4086 gcc_assert (fargs->sym->attr.dimension == 0);
4089 if (fsym->ts.type == BT_CHARACTER)
4091 /* Copy string arguments. */
4094 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4095 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4097 /* Create a temporary to hold the value. */
4098 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4099 fsym->ts.u.cl->backend_decl
4100 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4102 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4103 temp_vars[n] = gfc_create_var (type, fsym->name);
4105 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4107 gfc_conv_expr (&rse, args->expr);
4108 gfc_conv_string_parameter (&rse);
4109 gfc_add_block_to_block (&se->pre, &lse.pre);
4110 gfc_add_block_to_block (&se->pre, &rse.pre);
4112 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4113 rse.string_length, rse.expr, fsym->ts.kind);
4114 gfc_add_block_to_block (&se->pre, &lse.post);
4115 gfc_add_block_to_block (&se->pre, &rse.post);
4119 /* For everything else, just evaluate the expression. */
4121 /* Create a temporary to hold the value. */
4122 type = gfc_typenode_for_spec (&fsym->ts);
4123 temp_vars[n] = gfc_create_var (type, fsym->name);
4125 gfc_conv_expr (&lse, args->expr);
4127 gfc_add_block_to_block (&se->pre, &lse.pre);
4128 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4129 gfc_add_block_to_block (&se->pre, &lse.post);
4135 /* Use the temporary variables in place of the real ones. */
4136 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4137 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4139 gfc_conv_expr (se, sym->value);
4141 if (sym->ts.type == BT_CHARACTER)
4143 gfc_conv_const_charlen (sym->ts.u.cl);
4145 /* Force the expression to the correct length. */
4146 if (!INTEGER_CST_P (se->string_length)
4147 || tree_int_cst_lt (se->string_length,
4148 sym->ts.u.cl->backend_decl))
4150 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4151 tmp = gfc_create_var (type, sym->name);
4152 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4153 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4154 sym->ts.kind, se->string_length, se->expr,
4158 se->string_length = sym->ts.u.cl->backend_decl;
4161 /* Restore the original variables. */
4162 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4163 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4168 /* Translate a function expression. */
4171 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4175 if (expr->value.function.isym)
4177 gfc_conv_intrinsic_function (se, expr);
4181 /* We distinguish statement functions from general functions to improve
4182 runtime performance. */
4183 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4185 gfc_conv_statement_function (se, expr);
4189 /* expr.value.function.esym is the resolved (specific) function symbol for
4190 most functions. However this isn't set for dummy procedures. */
4191 sym = expr->value.function.esym;
4193 sym = expr->symtree->n.sym;
4195 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4199 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4202 is_zero_initializer_p (gfc_expr * expr)
4204 if (expr->expr_type != EXPR_CONSTANT)
4207 /* We ignore constants with prescribed memory representations for now. */
4208 if (expr->representation.string)
4211 switch (expr->ts.type)
4214 return mpz_cmp_si (expr->value.integer, 0) == 0;
4217 return mpfr_zero_p (expr->value.real)
4218 && MPFR_SIGN (expr->value.real) >= 0;
4221 return expr->value.logical == 0;
4224 return mpfr_zero_p (mpc_realref (expr->value.complex))
4225 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4226 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4227 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4237 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4239 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4240 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4242 gfc_conv_tmp_array_ref (se);
4246 /* Build a static initializer. EXPR is the expression for the initial value.
4247 The other parameters describe the variable of the component being
4248 initialized. EXPR may be null. */
4251 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4252 bool array, bool pointer, bool procptr)
4256 if (!(expr || pointer || procptr))
4259 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4260 (these are the only two iso_c_binding derived types that can be
4261 used as initialization expressions). If so, we need to modify
4262 the 'expr' to be that for a (void *). */
4263 if (expr != NULL && expr->ts.type == BT_DERIVED
4264 && expr->ts.is_iso_c && expr->ts.u.derived)
4266 gfc_symbol *derived = expr->ts.u.derived;
4268 /* The derived symbol has already been converted to a (void *). Use
4270 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4271 expr->ts.f90_type = derived->ts.f90_type;
4273 gfc_init_se (&se, NULL);
4274 gfc_conv_constant (&se, expr);
4275 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4279 if (array && !procptr)
4282 /* Arrays need special handling. */
4284 ctor = gfc_build_null_descriptor (type);
4285 /* Special case assigning an array to zero. */
4286 else if (is_zero_initializer_p (expr))
4287 ctor = build_constructor (type, NULL);
4289 ctor = gfc_conv_array_initializer (type, expr);
4290 TREE_STATIC (ctor) = 1;
4293 else if (pointer || procptr)
4295 if (!expr || expr->expr_type == EXPR_NULL)
4296 return fold_convert (type, null_pointer_node);
4299 gfc_init_se (&se, NULL);
4300 se.want_pointer = 1;
4301 gfc_conv_expr (&se, expr);
4302 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4312 gfc_init_se (&se, NULL);
4313 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4314 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4316 gfc_conv_structure (&se, expr, 1);
4317 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4318 TREE_STATIC (se.expr) = 1;
4323 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4324 TREE_STATIC (ctor) = 1;
4329 gfc_init_se (&se, NULL);
4330 gfc_conv_constant (&se, expr);
4331 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4338 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4350 gfc_start_block (&block);
4352 /* Initialize the scalarizer. */
4353 gfc_init_loopinfo (&loop);
4355 gfc_init_se (&lse, NULL);
4356 gfc_init_se (&rse, NULL);
4359 rss = gfc_walk_expr (expr);
4360 if (rss == gfc_ss_terminator)
4362 /* The rhs is scalar. Add a ss for the expression. */
4363 rss = gfc_get_ss ();
4364 rss->next = gfc_ss_terminator;
4365 rss->type = GFC_SS_SCALAR;
4369 /* Create a SS for the destination. */
4370 lss = gfc_get_ss ();
4371 lss->type = GFC_SS_COMPONENT;
4373 lss->shape = gfc_get_shape (cm->as->rank);
4374 lss->next = gfc_ss_terminator;
4375 lss->data.info.dimen = cm->as->rank;
4376 lss->data.info.descriptor = dest;
4377 lss->data.info.data = gfc_conv_array_data (dest);
4378 lss->data.info.offset = gfc_conv_array_offset (dest);
4379 for (n = 0; n < cm->as->rank; n++)
4381 lss->data.info.dim[n] = n;
4382 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4383 lss->data.info.stride[n] = gfc_index_one_node;
4385 mpz_init (lss->shape[n]);
4386 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4387 cm->as->lower[n]->value.integer);
4388 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4391 /* Associate the SS with the loop. */
4392 gfc_add_ss_to_loop (&loop, lss);
4393 gfc_add_ss_to_loop (&loop, rss);
4395 /* Calculate the bounds of the scalarization. */
4396 gfc_conv_ss_startstride (&loop);
4398 /* Setup the scalarizing loops. */
4399 gfc_conv_loop_setup (&loop, &expr->where);
4401 /* Setup the gfc_se structures. */
4402 gfc_copy_loopinfo_to_se (&lse, &loop);
4403 gfc_copy_loopinfo_to_se (&rse, &loop);
4406 gfc_mark_ss_chain_used (rss, 1);
4408 gfc_mark_ss_chain_used (lss, 1);
4410 /* Start the scalarized loop body. */
4411 gfc_start_scalarized_body (&loop, &body);
4413 gfc_conv_tmp_array_ref (&lse);
4414 if (cm->ts.type == BT_CHARACTER)
4415 lse.string_length = cm->ts.u.cl->backend_decl;
4417 gfc_conv_expr (&rse, expr);
4419 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4420 gfc_add_expr_to_block (&body, tmp);
4422 gcc_assert (rse.ss == gfc_ss_terminator);
4424 /* Generate the copying loops. */
4425 gfc_trans_scalarizing_loops (&loop, &body);
4427 /* Wrap the whole thing up. */
4428 gfc_add_block_to_block (&block, &loop.pre);
4429 gfc_add_block_to_block (&block, &loop.post);
4431 gcc_assert (lss->shape != NULL);
4432 gfc_free_shape (&lss->shape, cm->as->rank);
4433 gfc_cleanup_loop (&loop);
4435 return gfc_finish_block (&block);
4440 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4451 gfc_expr *arg = NULL;
4453 gfc_start_block (&block);
4454 gfc_init_se (&se, NULL);
4456 /* Get the descriptor for the expressions. */
4457 rss = gfc_walk_expr (expr);
4458 se.want_pointer = 0;
4459 gfc_conv_expr_descriptor (&se, expr, rss);
4460 gfc_add_block_to_block (&block, &se.pre);
4461 gfc_add_modify (&block, dest, se.expr);
4463 /* Deal with arrays of derived types with allocatable components. */
4464 if (cm->ts.type == BT_DERIVED
4465 && cm->ts.u.derived->attr.alloc_comp)
4466 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4470 tmp = gfc_duplicate_allocatable (dest, se.expr,
4471 TREE_TYPE(cm->backend_decl),
4474 gfc_add_expr_to_block (&block, tmp);
4475 gfc_add_block_to_block (&block, &se.post);
4477 if (expr->expr_type != EXPR_VARIABLE)
4478 gfc_conv_descriptor_data_set (&block, se.expr,
4481 /* We need to know if the argument of a conversion function is a
4482 variable, so that the correct lower bound can be used. */
4483 if (expr->expr_type == EXPR_FUNCTION
4484 && expr->value.function.isym
4485 && expr->value.function.isym->conversion
4486 && expr->value.function.actual->expr
4487 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4488 arg = expr->value.function.actual->expr;
4490 /* Obtain the array spec of full array references. */
4492 as = gfc_get_full_arrayspec_from_expr (arg);
4494 as = gfc_get_full_arrayspec_from_expr (expr);
4496 /* Shift the lbound and ubound of temporaries to being unity,
4497 rather than zero, based. Always calculate the offset. */
4498 offset = gfc_conv_descriptor_offset_get (dest);
4499 gfc_add_modify (&block, offset, gfc_index_zero_node);
4500 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4502 for (n = 0; n < expr->rank; n++)
4507 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4508 TODO It looks as if gfc_conv_expr_descriptor should return
4509 the correct bounds and that the following should not be
4510 necessary. This would simplify gfc_conv_intrinsic_bound
4512 if (as && as->lower[n])
4515 gfc_init_se (&lbse, NULL);
4516 gfc_conv_expr (&lbse, as->lower[n]);
4517 gfc_add_block_to_block (&block, &lbse.pre);
4518 lbound = gfc_evaluate_now (lbse.expr, &block);
4522 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4523 lbound = gfc_conv_descriptor_lbound_get (tmp,
4527 lbound = gfc_conv_descriptor_lbound_get (dest,
4530 lbound = gfc_index_one_node;
4532 lbound = fold_convert (gfc_array_index_type, lbound);
4534 /* Shift the bounds and set the offset accordingly. */
4535 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4536 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4537 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4538 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4540 gfc_conv_descriptor_ubound_set (&block, dest,
4541 gfc_rank_cst[n], tmp);
4542 gfc_conv_descriptor_lbound_set (&block, dest,
4543 gfc_rank_cst[n], lbound);
4545 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4546 gfc_conv_descriptor_lbound_get (dest,
4548 gfc_conv_descriptor_stride_get (dest,
4550 gfc_add_modify (&block, tmp2, tmp);
4551 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4553 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4558 /* If a conversion expression has a null data pointer
4559 argument, nullify the allocatable component. */
4563 if (arg->symtree->n.sym->attr.allocatable
4564 || arg->symtree->n.sym->attr.pointer)
4566 non_null_expr = gfc_finish_block (&block);
4567 gfc_start_block (&block);
4568 gfc_conv_descriptor_data_set (&block, dest,
4570 null_expr = gfc_finish_block (&block);
4571 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4572 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4573 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4574 return build3_v (COND_EXPR, tmp,
4575 null_expr, non_null_expr);
4579 return gfc_finish_block (&block);
4583 /* Assign a single component of a derived type constructor. */
4586 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4594 gfc_start_block (&block);
4596 if (cm->attr.pointer)
4598 gfc_init_se (&se, NULL);
4599 /* Pointer component. */
4600 if (cm->attr.dimension)
4602 /* Array pointer. */
4603 if (expr->expr_type == EXPR_NULL)
4604 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4607 rss = gfc_walk_expr (expr);
4608 se.direct_byref = 1;
4610 gfc_conv_expr_descriptor (&se, expr, rss);
4611 gfc_add_block_to_block (&block, &se.pre);
4612 gfc_add_block_to_block (&block, &se.post);
4617 /* Scalar pointers. */
4618 se.want_pointer = 1;
4619 gfc_conv_expr (&se, expr);
4620 gfc_add_block_to_block (&block, &se.pre);
4621 gfc_add_modify (&block, dest,
4622 fold_convert (TREE_TYPE (dest), se.expr));
4623 gfc_add_block_to_block (&block, &se.post);
4626 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4628 /* NULL initialization for CLASS components. */
4629 tmp = gfc_trans_structure_assign (dest,
4630 gfc_class_null_initializer (&cm->ts));
4631 gfc_add_expr_to_block (&block, tmp);
4633 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4635 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4636 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4637 else if (cm->attr.allocatable)
4639 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4640 gfc_add_expr_to_block (&block, tmp);
4644 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4645 gfc_add_expr_to_block (&block, tmp);
4648 else if (expr->ts.type == BT_DERIVED)
4650 if (expr->expr_type != EXPR_STRUCTURE)
4652 gfc_init_se (&se, NULL);
4653 gfc_conv_expr (&se, expr);
4654 gfc_add_block_to_block (&block, &se.pre);
4655 gfc_add_modify (&block, dest,
4656 fold_convert (TREE_TYPE (dest), se.expr));
4657 gfc_add_block_to_block (&block, &se.post);
4661 /* Nested constructors. */
4662 tmp = gfc_trans_structure_assign (dest, expr);
4663 gfc_add_expr_to_block (&block, tmp);
4668 /* Scalar component. */
4669 gfc_init_se (&se, NULL);
4670 gfc_init_se (&lse, NULL);
4672 gfc_conv_expr (&se, expr);
4673 if (cm->ts.type == BT_CHARACTER)
4674 lse.string_length = cm->ts.u.cl->backend_decl;
4676 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4677 gfc_add_expr_to_block (&block, tmp);
4679 return gfc_finish_block (&block);
4682 /* Assign a derived type constructor to a variable. */
4685 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4693 gfc_start_block (&block);
4694 cm = expr->ts.u.derived->components;
4696 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4697 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4698 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4702 gcc_assert (cm->backend_decl == NULL);
4703 gfc_init_se (&se, NULL);
4704 gfc_init_se (&lse, NULL);
4705 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4707 gfc_add_modify (&block, lse.expr,
4708 fold_convert (TREE_TYPE (lse.expr), se.expr));
4710 return gfc_finish_block (&block);
4713 for (c = gfc_constructor_first (expr->value.constructor);
4714 c; c = gfc_constructor_next (c), cm = cm->next)
4716 /* Skip absent members in default initializers. */
4720 field = cm->backend_decl;
4721 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4722 dest, field, NULL_TREE);
4723 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4724 gfc_add_expr_to_block (&block, tmp);
4726 return gfc_finish_block (&block);
4729 /* Build an expression for a constructor. If init is nonzero then
4730 this is part of a static variable initializer. */
4733 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4740 VEC(constructor_elt,gc) *v = NULL;
4742 gcc_assert (se->ss == NULL);
4743 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4744 type = gfc_typenode_for_spec (&expr->ts);
4748 /* Create a temporary variable and fill it in. */
4749 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4750 tmp = gfc_trans_structure_assign (se->expr, expr);
4751 gfc_add_expr_to_block (&se->pre, tmp);
4755 cm = expr->ts.u.derived->components;
4757 for (c = gfc_constructor_first (expr->value.constructor);
4758 c; c = gfc_constructor_next (c), cm = cm->next)
4760 /* Skip absent members in default initializers and allocatable
4761 components. Although the latter have a default initializer
4762 of EXPR_NULL,... by default, the static nullify is not needed
4763 since this is done every time we come into scope. */
4764 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4767 if (strcmp (cm->name, "_size") == 0)
4769 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4770 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4772 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4773 && strcmp (cm->name, "_extends") == 0)
4777 vtabs = cm->initializer->symtree->n.sym;
4778 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4779 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4783 val = gfc_conv_initializer (c->expr, &cm->ts,
4784 TREE_TYPE (cm->backend_decl),
4785 cm->attr.dimension, cm->attr.pointer,
4786 cm->attr.proc_pointer);
4788 /* Append it to the constructor list. */
4789 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4792 se->expr = build_constructor (type, v);
4794 TREE_CONSTANT (se->expr) = 1;
4798 /* Translate a substring expression. */
4801 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4807 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4809 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4810 expr->value.character.length,
4811 expr->value.character.string);
4813 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4814 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4817 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4821 /* Entry point for expression translation. Evaluates a scalar quantity.
4822 EXPR is the expression to be translated, and SE is the state structure if
4823 called from within the scalarized. */
4826 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4828 if (se->ss && se->ss->expr == expr
4829 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4831 /* Substitute a scalar expression evaluated outside the scalarization
4833 se->expr = se->ss->data.scalar.expr;
4834 if (se->ss->type == GFC_SS_REFERENCE)
4835 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4836 se->string_length = se->ss->string_length;
4837 gfc_advance_se_ss_chain (se);
4841 /* We need to convert the expressions for the iso_c_binding derived types.
4842 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4843 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4844 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4845 updated to be an integer with a kind equal to the size of a (void *). */
4846 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4847 && expr->ts.u.derived->attr.is_iso_c)
4849 if (expr->expr_type == EXPR_VARIABLE
4850 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4851 || expr->symtree->n.sym->intmod_sym_id
4852 == ISOCBINDING_NULL_FUNPTR))
4854 /* Set expr_type to EXPR_NULL, which will result in
4855 null_pointer_node being used below. */
4856 expr->expr_type = EXPR_NULL;
4860 /* Update the type/kind of the expression to be what the new
4861 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4862 expr->ts.type = expr->ts.u.derived->ts.type;
4863 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4864 expr->ts.kind = expr->ts.u.derived->ts.kind;
4868 switch (expr->expr_type)
4871 gfc_conv_expr_op (se, expr);
4875 gfc_conv_function_expr (se, expr);
4879 gfc_conv_constant (se, expr);
4883 gfc_conv_variable (se, expr);
4887 se->expr = null_pointer_node;
4890 case EXPR_SUBSTRING:
4891 gfc_conv_substring_expr (se, expr);
4894 case EXPR_STRUCTURE:
4895 gfc_conv_structure (se, expr, 0);
4899 gfc_conv_array_constructor_expr (se, expr);
4908 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4909 of an assignment. */
4911 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4913 gfc_conv_expr (se, expr);
4914 /* All numeric lvalues should have empty post chains. If not we need to
4915 figure out a way of rewriting an lvalue so that it has no post chain. */
4916 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4919 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4920 numeric expressions. Used for scalar values where inserting cleanup code
4923 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4927 gcc_assert (expr->ts.type != BT_CHARACTER);
4928 gfc_conv_expr (se, expr);
4931 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4932 gfc_add_modify (&se->pre, val, se->expr);
4934 gfc_add_block_to_block (&se->pre, &se->post);
4938 /* Helper to translate an expression and convert it to a particular type. */
4940 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4942 gfc_conv_expr_val (se, expr);
4943 se->expr = convert (type, se->expr);
4947 /* Converts an expression so that it can be passed by reference. Scalar
4951 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4955 if (se->ss && se->ss->expr == expr
4956 && se->ss->type == GFC_SS_REFERENCE)
4958 /* Returns a reference to the scalar evaluated outside the loop
4960 gfc_conv_expr (se, expr);
4964 if (expr->ts.type == BT_CHARACTER)
4966 gfc_conv_expr (se, expr);
4967 gfc_conv_string_parameter (se);
4971 if (expr->expr_type == EXPR_VARIABLE)
4973 se->want_pointer = 1;
4974 gfc_conv_expr (se, expr);
4977 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4978 gfc_add_modify (&se->pre, var, se->expr);
4979 gfc_add_block_to_block (&se->pre, &se->post);
4985 if (expr->expr_type == EXPR_FUNCTION
4986 && ((expr->value.function.esym
4987 && expr->value.function.esym->result->attr.pointer
4988 && !expr->value.function.esym->result->attr.dimension)
4989 || (!expr->value.function.esym
4990 && expr->symtree->n.sym->attr.pointer
4991 && !expr->symtree->n.sym->attr.dimension)))
4993 se->want_pointer = 1;
4994 gfc_conv_expr (se, expr);
4995 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4996 gfc_add_modify (&se->pre, var, se->expr);
5002 gfc_conv_expr (se, expr);
5004 /* Create a temporary var to hold the value. */
5005 if (TREE_CONSTANT (se->expr))
5007 tree tmp = se->expr;
5008 STRIP_TYPE_NOPS (tmp);
5009 var = build_decl (input_location,
5010 CONST_DECL, NULL, TREE_TYPE (tmp));
5011 DECL_INITIAL (var) = tmp;
5012 TREE_STATIC (var) = 1;
5017 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5018 gfc_add_modify (&se->pre, var, se->expr);
5020 gfc_add_block_to_block (&se->pre, &se->post);
5022 /* Take the address of that value. */
5023 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5028 gfc_trans_pointer_assign (gfc_code * code)
5030 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5034 /* Generate code for a pointer assignment. */
5037 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5048 gfc_start_block (&block);
5050 gfc_init_se (&lse, NULL);
5052 lss = gfc_walk_expr (expr1);
5053 rss = gfc_walk_expr (expr2);
5054 if (lss == gfc_ss_terminator)
5056 /* Scalar pointers. */
5057 lse.want_pointer = 1;
5058 gfc_conv_expr (&lse, expr1);
5059 gcc_assert (rss == gfc_ss_terminator);
5060 gfc_init_se (&rse, NULL);
5061 rse.want_pointer = 1;
5062 gfc_conv_expr (&rse, expr2);
5064 if (expr1->symtree->n.sym->attr.proc_pointer
5065 && expr1->symtree->n.sym->attr.dummy)
5066 lse.expr = build_fold_indirect_ref_loc (input_location,
5069 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5070 && expr2->symtree->n.sym->attr.dummy)
5071 rse.expr = build_fold_indirect_ref_loc (input_location,
5074 gfc_add_block_to_block (&block, &lse.pre);
5075 gfc_add_block_to_block (&block, &rse.pre);
5077 /* Check character lengths if character expression. The test is only
5078 really added if -fbounds-check is enabled. Exclude deferred
5079 character length lefthand sides. */
5080 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5081 && !(expr1->ts.deferred
5082 && (TREE_CODE (lse.string_length) == VAR_DECL))
5083 && !expr1->symtree->n.sym->attr.proc_pointer
5084 && !gfc_is_proc_ptr_comp (expr1, NULL))
5086 gcc_assert (expr2->ts.type == BT_CHARACTER);
5087 gcc_assert (lse.string_length && rse.string_length);
5088 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5089 lse.string_length, rse.string_length,
5093 /* The assignment to an deferred character length sets the string
5094 length to that of the rhs. */
5095 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5097 if (expr2->expr_type != EXPR_NULL)
5098 gfc_add_modify (&block, lse.string_length, rse.string_length);
5100 gfc_add_modify (&block, lse.string_length,
5101 build_int_cst (gfc_charlen_type_node, 0));
5104 gfc_add_modify (&block, lse.expr,
5105 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5107 gfc_add_block_to_block (&block, &rse.post);
5108 gfc_add_block_to_block (&block, &lse.post);
5115 tree strlen_rhs = NULL_TREE;
5117 /* Array pointer. Find the last reference on the LHS and if it is an
5118 array section ref, we're dealing with bounds remapping. In this case,
5119 set it to AR_FULL so that gfc_conv_expr_descriptor does
5120 not see it and process the bounds remapping afterwards explicitely. */
5121 for (remap = expr1->ref; remap; remap = remap->next)
5122 if (!remap->next && remap->type == REF_ARRAY
5123 && remap->u.ar.type == AR_SECTION)
5125 remap->u.ar.type = AR_FULL;
5128 rank_remap = (remap && remap->u.ar.end[0]);
5130 gfc_conv_expr_descriptor (&lse, expr1, lss);
5131 strlen_lhs = lse.string_length;
5134 if (expr2->expr_type == EXPR_NULL)
5136 /* Just set the data pointer to null. */
5137 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5139 else if (rank_remap)
5141 /* If we are rank-remapping, just get the RHS's descriptor and
5142 process this later on. */
5143 gfc_init_se (&rse, NULL);
5144 rse.direct_byref = 1;
5145 rse.byref_noassign = 1;
5146 gfc_conv_expr_descriptor (&rse, expr2, rss);
5147 strlen_rhs = rse.string_length;
5149 else if (expr2->expr_type == EXPR_VARIABLE)
5151 /* Assign directly to the LHS's descriptor. */
5152 lse.direct_byref = 1;
5153 gfc_conv_expr_descriptor (&lse, expr2, rss);
5154 strlen_rhs = lse.string_length;
5156 /* If this is a subreference array pointer assignment, use the rhs
5157 descriptor element size for the lhs span. */
5158 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5160 decl = expr1->symtree->n.sym->backend_decl;
5161 gfc_init_se (&rse, NULL);
5162 rse.descriptor_only = 1;
5163 gfc_conv_expr (&rse, expr2);
5164 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5165 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5166 if (!INTEGER_CST_P (tmp))
5167 gfc_add_block_to_block (&lse.post, &rse.pre);
5168 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5173 /* Assign to a temporary descriptor and then copy that
5174 temporary to the pointer. */
5175 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5178 lse.direct_byref = 1;
5179 gfc_conv_expr_descriptor (&lse, expr2, rss);
5180 strlen_rhs = lse.string_length;
5181 gfc_add_modify (&lse.pre, desc, tmp);
5184 gfc_add_block_to_block (&block, &lse.pre);
5186 gfc_add_block_to_block (&block, &rse.pre);
5188 /* If we do bounds remapping, update LHS descriptor accordingly. */
5192 gcc_assert (remap->u.ar.dimen == expr1->rank);
5196 /* Do rank remapping. We already have the RHS's descriptor
5197 converted in rse and now have to build the correct LHS
5198 descriptor for it. */
5202 tree lbound, ubound;
5205 dtype = gfc_conv_descriptor_dtype (desc);
5206 tmp = gfc_get_dtype (TREE_TYPE (desc));
5207 gfc_add_modify (&block, dtype, tmp);
5209 /* Copy data pointer. */
5210 data = gfc_conv_descriptor_data_get (rse.expr);
5211 gfc_conv_descriptor_data_set (&block, desc, data);
5213 /* Copy offset but adjust it such that it would correspond
5214 to a lbound of zero. */
5215 offs = gfc_conv_descriptor_offset_get (rse.expr);
5216 for (dim = 0; dim < expr2->rank; ++dim)
5218 stride = gfc_conv_descriptor_stride_get (rse.expr,
5220 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5222 tmp = fold_build2_loc (input_location, MULT_EXPR,
5223 gfc_array_index_type, stride, lbound);
5224 offs = fold_build2_loc (input_location, PLUS_EXPR,
5225 gfc_array_index_type, offs, tmp);
5227 gfc_conv_descriptor_offset_set (&block, desc, offs);
5229 /* Set the bounds as declared for the LHS and calculate strides as
5230 well as another offset update accordingly. */
5231 stride = gfc_conv_descriptor_stride_get (rse.expr,
5233 for (dim = 0; dim < expr1->rank; ++dim)
5238 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5240 /* Convert declared bounds. */
5241 gfc_init_se (&lower_se, NULL);
5242 gfc_init_se (&upper_se, NULL);
5243 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5244 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5246 gfc_add_block_to_block (&block, &lower_se.pre);
5247 gfc_add_block_to_block (&block, &upper_se.pre);
5249 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5250 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5252 lbound = gfc_evaluate_now (lbound, &block);
5253 ubound = gfc_evaluate_now (ubound, &block);
5255 gfc_add_block_to_block (&block, &lower_se.post);
5256 gfc_add_block_to_block (&block, &upper_se.post);
5258 /* Set bounds in descriptor. */
5259 gfc_conv_descriptor_lbound_set (&block, desc,
5260 gfc_rank_cst[dim], lbound);
5261 gfc_conv_descriptor_ubound_set (&block, desc,
5262 gfc_rank_cst[dim], ubound);
5265 stride = gfc_evaluate_now (stride, &block);
5266 gfc_conv_descriptor_stride_set (&block, desc,
5267 gfc_rank_cst[dim], stride);
5269 /* Update offset. */
5270 offs = gfc_conv_descriptor_offset_get (desc);
5271 tmp = fold_build2_loc (input_location, MULT_EXPR,
5272 gfc_array_index_type, lbound, stride);
5273 offs = fold_build2_loc (input_location, MINUS_EXPR,
5274 gfc_array_index_type, offs, tmp);
5275 offs = gfc_evaluate_now (offs, &block);
5276 gfc_conv_descriptor_offset_set (&block, desc, offs);
5278 /* Update stride. */
5279 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5280 stride = fold_build2_loc (input_location, MULT_EXPR,
5281 gfc_array_index_type, stride, tmp);
5286 /* Bounds remapping. Just shift the lower bounds. */
5288 gcc_assert (expr1->rank == expr2->rank);
5290 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5294 gcc_assert (remap->u.ar.start[dim]);
5295 gcc_assert (!remap->u.ar.end[dim]);
5296 gfc_init_se (&lbound_se, NULL);
5297 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5299 gfc_add_block_to_block (&block, &lbound_se.pre);
5300 gfc_conv_shift_descriptor_lbound (&block, desc,
5301 dim, lbound_se.expr);
5302 gfc_add_block_to_block (&block, &lbound_se.post);
5307 /* Check string lengths if applicable. The check is only really added
5308 to the output code if -fbounds-check is enabled. */
5309 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5311 gcc_assert (expr2->ts.type == BT_CHARACTER);
5312 gcc_assert (strlen_lhs && strlen_rhs);
5313 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5314 strlen_lhs, strlen_rhs, &block);
5317 /* If rank remapping was done, check with -fcheck=bounds that
5318 the target is at least as large as the pointer. */
5319 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5325 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5326 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5328 lsize = gfc_evaluate_now (lsize, &block);
5329 rsize = gfc_evaluate_now (rsize, &block);
5330 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5333 msg = _("Target of rank remapping is too small (%ld < %ld)");
5334 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5338 gfc_add_block_to_block (&block, &lse.post);
5340 gfc_add_block_to_block (&block, &rse.post);
5343 return gfc_finish_block (&block);
5347 /* Makes sure se is suitable for passing as a function string parameter. */
5348 /* TODO: Need to check all callers of this function. It may be abused. */
5351 gfc_conv_string_parameter (gfc_se * se)
5355 if (TREE_CODE (se->expr) == STRING_CST)
5357 type = TREE_TYPE (TREE_TYPE (se->expr));
5358 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5362 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5364 if (TREE_CODE (se->expr) != INDIRECT_REF)
5366 type = TREE_TYPE (se->expr);
5367 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5371 type = gfc_get_character_type_len (gfc_default_character_kind,
5373 type = build_pointer_type (type);
5374 se->expr = gfc_build_addr_expr (type, se->expr);
5378 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5382 /* Generate code for assignment of scalar variables. Includes character
5383 strings and derived types with allocatable components.
5384 If you know that the LHS has no allocations, set dealloc to false. */
5387 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5388 bool l_is_temp, bool r_is_var, bool dealloc)
5394 gfc_init_block (&block);
5396 if (ts.type == BT_CHARACTER)
5401 if (lse->string_length != NULL_TREE)
5403 gfc_conv_string_parameter (lse);
5404 gfc_add_block_to_block (&block, &lse->pre);
5405 llen = lse->string_length;
5408 if (rse->string_length != NULL_TREE)
5410 gcc_assert (rse->string_length != NULL_TREE);
5411 gfc_conv_string_parameter (rse);
5412 gfc_add_block_to_block (&block, &rse->pre);
5413 rlen = rse->string_length;
5416 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5417 rse->expr, ts.kind);
5419 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5423 /* Are the rhs and the lhs the same? */
5426 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5427 gfc_build_addr_expr (NULL_TREE, lse->expr),
5428 gfc_build_addr_expr (NULL_TREE, rse->expr));
5429 cond = gfc_evaluate_now (cond, &lse->pre);
5432 /* Deallocate the lhs allocated components as long as it is not
5433 the same as the rhs. This must be done following the assignment
5434 to prevent deallocating data that could be used in the rhs
5436 if (!l_is_temp && dealloc)
5438 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5439 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5441 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5443 gfc_add_expr_to_block (&lse->post, tmp);
5446 gfc_add_block_to_block (&block, &rse->pre);
5447 gfc_add_block_to_block (&block, &lse->pre);
5449 gfc_add_modify (&block, lse->expr,
5450 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5452 /* Do a deep copy if the rhs is a variable, if it is not the
5456 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5457 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5459 gfc_add_expr_to_block (&block, tmp);
5462 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5464 gfc_add_block_to_block (&block, &lse->pre);
5465 gfc_add_block_to_block (&block, &rse->pre);
5466 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5467 TREE_TYPE (lse->expr), rse->expr);
5468 gfc_add_modify (&block, lse->expr, tmp);
5472 gfc_add_block_to_block (&block, &lse->pre);
5473 gfc_add_block_to_block (&block, &rse->pre);
5475 gfc_add_modify (&block, lse->expr,
5476 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5479 gfc_add_block_to_block (&block, &lse->post);
5480 gfc_add_block_to_block (&block, &rse->post);
5482 return gfc_finish_block (&block);
5486 /* There are quite a lot of restrictions on the optimisation in using an
5487 array function assign without a temporary. */
5490 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5493 bool seen_array_ref;
5495 gfc_symbol *sym = expr1->symtree->n.sym;
5497 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5498 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5501 /* Elemental functions are scalarized so that they don't need a
5502 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5503 they would need special treatment in gfc_trans_arrayfunc_assign. */
5504 if (expr2->value.function.esym != NULL
5505 && expr2->value.function.esym->attr.elemental)
5508 /* Need a temporary if rhs is not FULL or a contiguous section. */
5509 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5512 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5513 if (gfc_ref_needs_temporary_p (expr1->ref))
5516 /* Functions returning pointers or allocatables need temporaries. */
5517 c = expr2->value.function.esym
5518 ? (expr2->value.function.esym->attr.pointer
5519 || expr2->value.function.esym->attr.allocatable)
5520 : (expr2->symtree->n.sym->attr.pointer
5521 || expr2->symtree->n.sym->attr.allocatable);
5525 /* Character array functions need temporaries unless the
5526 character lengths are the same. */
5527 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5529 if (expr1->ts.u.cl->length == NULL
5530 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5533 if (expr2->ts.u.cl->length == NULL
5534 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5537 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5538 expr2->ts.u.cl->length->value.integer) != 0)
5542 /* Check that no LHS component references appear during an array
5543 reference. This is needed because we do not have the means to
5544 span any arbitrary stride with an array descriptor. This check
5545 is not needed for the rhs because the function result has to be
5547 seen_array_ref = false;
5548 for (ref = expr1->ref; ref; ref = ref->next)
5550 if (ref->type == REF_ARRAY)
5551 seen_array_ref= true;
5552 else if (ref->type == REF_COMPONENT && seen_array_ref)
5556 /* Check for a dependency. */
5557 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5558 expr2->value.function.esym,
5559 expr2->value.function.actual,
5563 /* If we have reached here with an intrinsic function, we do not
5564 need a temporary except in the particular case that reallocation
5565 on assignment is active and the lhs is allocatable and a target. */
5566 if (expr2->value.function.isym)
5567 return (gfc_option.flag_realloc_lhs
5568 && sym->attr.allocatable
5569 && sym->attr.target);
5571 /* If the LHS is a dummy, we need a temporary if it is not
5573 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5576 /* If the lhs has been host_associated, is in common, a pointer or is
5577 a target and the function is not using a RESULT variable, aliasing
5578 can occur and a temporary is needed. */
5579 if ((sym->attr.host_assoc
5580 || sym->attr.in_common
5581 || sym->attr.pointer
5582 || sym->attr.cray_pointee
5583 || sym->attr.target)
5584 && expr2->symtree != NULL
5585 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5588 /* A PURE function can unconditionally be called without a temporary. */
5589 if (expr2->value.function.esym != NULL
5590 && expr2->value.function.esym->attr.pure)
5593 /* Implicit_pure functions are those which could legally be declared
5595 if (expr2->value.function.esym != NULL
5596 && expr2->value.function.esym->attr.implicit_pure)
5599 if (!sym->attr.use_assoc
5600 && !sym->attr.in_common
5601 && !sym->attr.pointer
5602 && !sym->attr.target
5603 && !sym->attr.cray_pointee
5604 && expr2->value.function.esym)
5606 /* A temporary is not needed if the function is not contained and
5607 the variable is local or host associated and not a pointer or
5609 if (!expr2->value.function.esym->attr.contained)
5612 /* A temporary is not needed if the lhs has never been host
5613 associated and the procedure is contained. */
5614 else if (!sym->attr.host_assoc)
5617 /* A temporary is not needed if the variable is local and not
5618 a pointer, a target or a result. */
5620 && expr2->value.function.esym->ns == sym->ns->parent)
5624 /* Default to temporary use. */
5629 /* Provide the loop info so that the lhs descriptor can be built for
5630 reallocatable assignments from extrinsic function calls. */
5633 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5636 /* Signal that the function call should not be made by
5637 gfc_conv_loop_setup. */
5638 se->ss->is_alloc_lhs = 1;
5639 gfc_init_loopinfo (loop);
5640 gfc_add_ss_to_loop (loop, *ss);
5641 gfc_add_ss_to_loop (loop, se->ss);
5642 gfc_conv_ss_startstride (loop);
5643 gfc_conv_loop_setup (loop, where);
5644 gfc_copy_loopinfo_to_se (se, loop);
5645 gfc_add_block_to_block (&se->pre, &loop->pre);
5646 gfc_add_block_to_block (&se->pre, &loop->post);
5647 se->ss->is_alloc_lhs = 0;
5651 /* For Assignment to a reallocatable lhs from intrinsic functions,
5652 replace the se.expr (ie. the result) with a temporary descriptor.
5653 Null the data field so that the library allocates space for the
5654 result. Free the data of the original descriptor after the function,
5655 in case it appears in an argument expression and transfer the
5656 result to the original descriptor. */
5659 fcncall_realloc_result (gfc_se *se, int rank)
5667 /* Use the allocation done by the library. Substitute the lhs
5668 descriptor with a copy, whose data field is nulled.*/
5669 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5670 /* Unallocated, the descriptor does not have a dtype. */
5671 tmp = gfc_conv_descriptor_dtype (desc);
5672 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5673 res_desc = gfc_evaluate_now (desc, &se->pre);
5674 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5675 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5677 /* Free the lhs after the function call and copy the result to
5678 the lhs descriptor. */
5679 tmp = gfc_conv_descriptor_data_get (desc);
5680 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5681 gfc_add_expr_to_block (&se->post, tmp);
5682 gfc_add_modify (&se->post, desc, res_desc);
5684 offset = gfc_index_zero_node;
5685 tmp = gfc_index_one_node;
5686 /* Now reset the bounds from zero based to unity based. */
5687 for (n = 0 ; n < rank; n++)
5689 /* Accumulate the offset. */
5690 offset = fold_build2_loc (input_location, MINUS_EXPR,
5691 gfc_array_index_type,
5693 /* Now do the bounds. */
5694 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5695 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5696 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5697 gfc_array_index_type,
5698 tmp, gfc_index_one_node);
5699 gfc_conv_descriptor_lbound_set (&se->post, desc,
5701 gfc_index_one_node);
5702 gfc_conv_descriptor_ubound_set (&se->post, desc,
5703 gfc_rank_cst[n], tmp);
5705 /* The extent for the next contribution to offset. */
5706 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5707 gfc_array_index_type,
5708 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5709 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5710 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5711 gfc_array_index_type,
5712 tmp, gfc_index_one_node);
5714 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5719 /* Try to translate array(:) = func (...), where func is a transformational
5720 array function, without using a temporary. Returns NULL if this isn't the
5724 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5728 gfc_component *comp = NULL;
5731 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5734 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5736 gcc_assert (expr2->value.function.isym
5737 || (gfc_is_proc_ptr_comp (expr2, &comp)
5738 && comp && comp->attr.dimension)
5739 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5740 && expr2->value.function.esym->result->attr.dimension));
5742 ss = gfc_walk_expr (expr1);
5743 gcc_assert (ss != gfc_ss_terminator);
5744 gfc_init_se (&se, NULL);
5745 gfc_start_block (&se.pre);
5746 se.want_pointer = 1;
5748 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5750 if (expr1->ts.type == BT_DERIVED
5751 && expr1->ts.u.derived->attr.alloc_comp)
5754 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5756 gfc_add_expr_to_block (&se.pre, tmp);
5759 se.direct_byref = 1;
5760 se.ss = gfc_walk_expr (expr2);
5761 gcc_assert (se.ss != gfc_ss_terminator);
5763 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5764 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5765 Clearly, this cannot be done for an allocatable function result, since
5766 the shape of the result is unknown and, in any case, the function must
5767 correctly take care of the reallocation internally. For intrinsic
5768 calls, the array data is freed and the library takes care of allocation.
5769 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5771 if (gfc_option.flag_realloc_lhs
5772 && gfc_is_reallocatable_lhs (expr1)
5773 && !gfc_expr_attr (expr1).codimension
5774 && !gfc_is_coindexed (expr1)
5775 && !(expr2->value.function.esym
5776 && expr2->value.function.esym->result->attr.allocatable))
5778 if (!expr2->value.function.isym)
5780 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5781 ss->is_alloc_lhs = 1;
5784 fcncall_realloc_result (&se, expr1->rank);
5787 gfc_conv_function_expr (&se, expr2);
5788 gfc_add_block_to_block (&se.pre, &se.post);
5790 return gfc_finish_block (&se.pre);
5794 /* Try to efficiently translate array(:) = 0. Return NULL if this
5798 gfc_trans_zero_assign (gfc_expr * expr)
5800 tree dest, len, type;
5804 sym = expr->symtree->n.sym;
5805 dest = gfc_get_symbol_decl (sym);
5807 type = TREE_TYPE (dest);
5808 if (POINTER_TYPE_P (type))
5809 type = TREE_TYPE (type);
5810 if (!GFC_ARRAY_TYPE_P (type))
5813 /* Determine the length of the array. */
5814 len = GFC_TYPE_ARRAY_SIZE (type);
5815 if (!len || TREE_CODE (len) != INTEGER_CST)
5818 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5819 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5820 fold_convert (gfc_array_index_type, tmp));
5822 /* If we are zeroing a local array avoid taking its address by emitting
5824 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5825 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5826 dest, build_constructor (TREE_TYPE (dest), NULL));
5828 /* Convert arguments to the correct types. */
5829 dest = fold_convert (pvoid_type_node, dest);
5830 len = fold_convert (size_type_node, len);
5832 /* Construct call to __builtin_memset. */
5833 tmp = build_call_expr_loc (input_location,
5834 built_in_decls[BUILT_IN_MEMSET],
5835 3, dest, integer_zero_node, len);
5836 return fold_convert (void_type_node, tmp);
5840 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5841 that constructs the call to __builtin_memcpy. */
5844 gfc_build_memcpy_call (tree dst, tree src, tree len)
5848 /* Convert arguments to the correct types. */
5849 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5850 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5852 dst = fold_convert (pvoid_type_node, dst);
5854 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5855 src = gfc_build_addr_expr (pvoid_type_node, src);
5857 src = fold_convert (pvoid_type_node, src);
5859 len = fold_convert (size_type_node, len);
5861 /* Construct call to __builtin_memcpy. */
5862 tmp = build_call_expr_loc (input_location,
5863 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5864 return fold_convert (void_type_node, tmp);
5868 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5869 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5870 source/rhs, both are gfc_full_array_ref_p which have been checked for
5874 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5876 tree dst, dlen, dtype;
5877 tree src, slen, stype;
5880 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5881 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5883 dtype = TREE_TYPE (dst);
5884 if (POINTER_TYPE_P (dtype))
5885 dtype = TREE_TYPE (dtype);
5886 stype = TREE_TYPE (src);
5887 if (POINTER_TYPE_P (stype))
5888 stype = TREE_TYPE (stype);
5890 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5893 /* Determine the lengths of the arrays. */
5894 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5895 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5897 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5898 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5899 dlen, fold_convert (gfc_array_index_type, tmp));
5901 slen = GFC_TYPE_ARRAY_SIZE (stype);
5902 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5904 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5905 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5906 slen, fold_convert (gfc_array_index_type, tmp));
5908 /* Sanity check that they are the same. This should always be
5909 the case, as we should already have checked for conformance. */
5910 if (!tree_int_cst_equal (slen, dlen))
5913 return gfc_build_memcpy_call (dst, src, dlen);
5917 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5918 this can't be done. EXPR1 is the destination/lhs for which
5919 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5922 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5924 unsigned HOST_WIDE_INT nelem;
5930 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5934 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5935 dtype = TREE_TYPE (dst);
5936 if (POINTER_TYPE_P (dtype))
5937 dtype = TREE_TYPE (dtype);
5938 if (!GFC_ARRAY_TYPE_P (dtype))
5941 /* Determine the lengths of the array. */
5942 len = GFC_TYPE_ARRAY_SIZE (dtype);
5943 if (!len || TREE_CODE (len) != INTEGER_CST)
5946 /* Confirm that the constructor is the same size. */
5947 if (compare_tree_int (len, nelem) != 0)
5950 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5951 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5952 fold_convert (gfc_array_index_type, tmp));
5954 stype = gfc_typenode_for_spec (&expr2->ts);
5955 src = gfc_build_constant_array_constructor (expr2, stype);
5957 stype = TREE_TYPE (src);
5958 if (POINTER_TYPE_P (stype))
5959 stype = TREE_TYPE (stype);
5961 return gfc_build_memcpy_call (dst, src, len);
5965 /* Tells whether the expression is to be treated as a variable reference. */
5968 expr_is_variable (gfc_expr *expr)
5972 if (expr->expr_type == EXPR_VARIABLE)
5975 arg = gfc_get_noncopying_intrinsic_argument (expr);
5978 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5979 return expr_is_variable (arg);
5986 /* Is the lhs OK for automatic reallocation? */
5989 is_scalar_reallocatable_lhs (gfc_expr *expr)
5993 /* An allocatable variable with no reference. */
5994 if (expr->symtree->n.sym->attr.allocatable
5998 /* All that can be left are allocatable components. */
5999 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6000 && expr->symtree->n.sym->ts.type != BT_CLASS)
6001 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6004 /* Find an allocatable component ref last. */
6005 for (ref = expr->ref; ref; ref = ref->next)
6006 if (ref->type == REF_COMPONENT
6008 && ref->u.c.component->attr.allocatable)
6015 /* Allocate or reallocate scalar lhs, as necessary. */
6018 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6032 if (!expr1 || expr1->rank)
6035 if (!expr2 || expr2->rank)
6038 /* Since this is a scalar lhs, we can afford to do this. That is,
6039 there is no risk of side effects being repeated. */
6040 gfc_init_se (&lse, NULL);
6041 lse.want_pointer = 1;
6042 gfc_conv_expr (&lse, expr1);
6044 jump_label1 = gfc_build_label_decl (NULL_TREE);
6045 jump_label2 = gfc_build_label_decl (NULL_TREE);
6047 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6048 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6049 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6051 tmp = build3_v (COND_EXPR, cond,
6052 build1_v (GOTO_EXPR, jump_label1),
6053 build_empty_stmt (input_location));
6054 gfc_add_expr_to_block (block, tmp);
6056 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6058 /* Use the rhs string length and the lhs element size. */
6059 size = string_length;
6060 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6061 tmp = TYPE_SIZE_UNIT (tmp);
6062 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6063 TREE_TYPE (tmp), tmp,
6064 fold_convert (TREE_TYPE (tmp), size));
6068 /* Otherwise use the length in bytes of the rhs. */
6069 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6070 size_in_bytes = size;
6073 tmp = build_call_expr_loc (input_location,
6074 built_in_decls[BUILT_IN_MALLOC], 1,
6076 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6077 gfc_add_modify (block, lse.expr, tmp);
6078 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6080 /* Deferred characters need checking for lhs and rhs string
6081 length. Other deferred parameter variables will have to
6083 tmp = build1_v (GOTO_EXPR, jump_label2);
6084 gfc_add_expr_to_block (block, tmp);
6086 tmp = build1_v (LABEL_EXPR, jump_label1);
6087 gfc_add_expr_to_block (block, tmp);
6089 /* For a deferred length character, reallocate if lengths of lhs and
6090 rhs are different. */
6091 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6093 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6094 expr1->ts.u.cl->backend_decl, size);
6095 /* Jump past the realloc if the lengths are the same. */
6096 tmp = build3_v (COND_EXPR, cond,
6097 build1_v (GOTO_EXPR, jump_label2),
6098 build_empty_stmt (input_location));
6099 gfc_add_expr_to_block (block, tmp);
6100 tmp = build_call_expr_loc (input_location,
6101 built_in_decls[BUILT_IN_REALLOC], 2,
6102 fold_convert (pvoid_type_node, lse.expr),
6104 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6105 gfc_add_modify (block, lse.expr, tmp);
6106 tmp = build1_v (LABEL_EXPR, jump_label2);
6107 gfc_add_expr_to_block (block, tmp);
6109 /* Update the lhs character length. */
6110 size = string_length;
6111 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6116 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6117 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6118 init_flag indicates initialization expressions and dealloc that no
6119 deallocate prior assignment is needed (if in doubt, set true). */
6122 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6128 gfc_ss *lss_section;
6135 bool scalar_to_array;
6140 /* Assignment of the form lhs = rhs. */
6141 gfc_start_block (&block);
6143 gfc_init_se (&lse, NULL);
6144 gfc_init_se (&rse, NULL);
6147 lss = gfc_walk_expr (expr1);
6148 if (gfc_is_reallocatable_lhs (expr1)
6149 && !(expr2->expr_type == EXPR_FUNCTION
6150 && expr2->value.function.isym != NULL))
6151 lss->is_alloc_lhs = 1;
6153 if (lss != gfc_ss_terminator)
6155 /* The assignment needs scalarization. */
6158 /* Find a non-scalar SS from the lhs. */
6159 while (lss_section != gfc_ss_terminator
6160 && lss_section->type != GFC_SS_SECTION)
6161 lss_section = lss_section->next;
6163 gcc_assert (lss_section != gfc_ss_terminator);
6165 /* Initialize the scalarizer. */
6166 gfc_init_loopinfo (&loop);
6169 rss = gfc_walk_expr (expr2);
6170 if (rss == gfc_ss_terminator)
6172 /* The rhs is scalar. Add a ss for the expression. */
6173 rss = gfc_get_ss ();
6174 rss->next = gfc_ss_terminator;
6175 rss->type = GFC_SS_SCALAR;
6178 /* Associate the SS with the loop. */
6179 gfc_add_ss_to_loop (&loop, lss);
6180 gfc_add_ss_to_loop (&loop, rss);
6182 /* Calculate the bounds of the scalarization. */
6183 gfc_conv_ss_startstride (&loop);
6184 /* Enable loop reversal. */
6185 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6186 loop.reverse[n] = GFC_ENABLE_REVERSE;
6187 /* Resolve any data dependencies in the statement. */
6188 gfc_conv_resolve_dependencies (&loop, lss, rss);
6189 /* Setup the scalarizing loops. */
6190 gfc_conv_loop_setup (&loop, &expr2->where);
6192 /* Setup the gfc_se structures. */
6193 gfc_copy_loopinfo_to_se (&lse, &loop);
6194 gfc_copy_loopinfo_to_se (&rse, &loop);
6197 gfc_mark_ss_chain_used (rss, 1);
6198 if (loop.temp_ss == NULL)
6201 gfc_mark_ss_chain_used (lss, 1);
6205 lse.ss = loop.temp_ss;
6206 gfc_mark_ss_chain_used (lss, 3);
6207 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6210 /* Allow the scalarizer to workshare array assignments. */
6211 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6212 ompws_flags |= OMPWS_SCALARIZER_WS;
6214 /* Start the scalarized loop body. */
6215 gfc_start_scalarized_body (&loop, &body);
6218 gfc_init_block (&body);
6220 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6222 /* Translate the expression. */
6223 gfc_conv_expr (&rse, expr2);
6225 /* Stabilize a string length for temporaries. */
6226 if (expr2->ts.type == BT_CHARACTER)
6227 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6229 string_length = NULL_TREE;
6233 gfc_conv_tmp_array_ref (&lse);
6234 if (expr2->ts.type == BT_CHARACTER)
6235 lse.string_length = string_length;
6238 gfc_conv_expr (&lse, expr1);
6240 /* Assignments of scalar derived types with allocatable components
6241 to arrays must be done with a deep copy and the rhs temporary
6242 must have its components deallocated afterwards. */
6243 scalar_to_array = (expr2->ts.type == BT_DERIVED
6244 && expr2->ts.u.derived->attr.alloc_comp
6245 && !expr_is_variable (expr2)
6246 && !gfc_is_constant_expr (expr2)
6247 && expr1->rank && !expr2->rank);
6248 if (scalar_to_array && dealloc)
6250 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6251 gfc_add_expr_to_block (&loop.post, tmp);
6254 /* For a deferred character length function, the function call must
6255 happen before the (re)allocation of the lhs, otherwise the character
6256 length of the result is not known. */
6257 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6258 || (expr2->expr_type == EXPR_COMPCALL)
6259 || (expr2->expr_type == EXPR_PPC))
6260 && expr2->ts.deferred);
6261 if (gfc_option.flag_realloc_lhs
6262 && expr2->ts.type == BT_CHARACTER
6263 && (def_clen_func || expr2->expr_type == EXPR_OP)
6264 && expr1->ts.deferred)
6265 gfc_add_block_to_block (&block, &rse.pre);
6267 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6268 l_is_temp || init_flag,
6269 expr_is_variable (expr2) || scalar_to_array
6270 || expr2->expr_type == EXPR_ARRAY, dealloc);
6271 gfc_add_expr_to_block (&body, tmp);
6273 if (lss == gfc_ss_terminator)
6275 /* F2003: Add the code for reallocation on assignment. */
6276 if (gfc_option.flag_realloc_lhs
6277 && is_scalar_reallocatable_lhs (expr1))
6278 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6281 /* Use the scalar assignment as is. */
6282 gfc_add_block_to_block (&block, &body);
6286 gcc_assert (lse.ss == gfc_ss_terminator
6287 && rse.ss == gfc_ss_terminator);
6291 gfc_trans_scalarized_loop_boundary (&loop, &body);
6293 /* We need to copy the temporary to the actual lhs. */
6294 gfc_init_se (&lse, NULL);
6295 gfc_init_se (&rse, NULL);
6296 gfc_copy_loopinfo_to_se (&lse, &loop);
6297 gfc_copy_loopinfo_to_se (&rse, &loop);
6299 rse.ss = loop.temp_ss;
6302 gfc_conv_tmp_array_ref (&rse);
6303 gfc_conv_expr (&lse, expr1);
6305 gcc_assert (lse.ss == gfc_ss_terminator
6306 && rse.ss == gfc_ss_terminator);
6308 if (expr2->ts.type == BT_CHARACTER)
6309 rse.string_length = string_length;
6311 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6312 false, false, dealloc);
6313 gfc_add_expr_to_block (&body, tmp);
6316 /* F2003: Allocate or reallocate lhs of allocatable array. */
6317 if (gfc_option.flag_realloc_lhs
6318 && gfc_is_reallocatable_lhs (expr1)
6319 && !gfc_expr_attr (expr1).codimension
6320 && !gfc_is_coindexed (expr1))
6322 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6323 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6324 if (tmp != NULL_TREE)
6325 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6328 /* Generate the copying loops. */
6329 gfc_trans_scalarizing_loops (&loop, &body);
6331 /* Wrap the whole thing up. */
6332 gfc_add_block_to_block (&block, &loop.pre);
6333 gfc_add_block_to_block (&block, &loop.post);
6335 gfc_cleanup_loop (&loop);
6338 return gfc_finish_block (&block);
6342 /* Check whether EXPR is a copyable array. */
6345 copyable_array_p (gfc_expr * expr)
6347 if (expr->expr_type != EXPR_VARIABLE)
6350 /* First check it's an array. */
6351 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6354 if (!gfc_full_array_ref_p (expr->ref, NULL))
6357 /* Next check that it's of a simple enough type. */
6358 switch (expr->ts.type)
6370 return !expr->ts.u.derived->attr.alloc_comp;
6379 /* Translate an assignment. */
6382 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6387 /* Special case a single function returning an array. */
6388 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6390 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6395 /* Special case assigning an array to zero. */
6396 if (copyable_array_p (expr1)
6397 && is_zero_initializer_p (expr2))
6399 tmp = gfc_trans_zero_assign (expr1);
6404 /* Special case copying one array to another. */
6405 if (copyable_array_p (expr1)
6406 && copyable_array_p (expr2)
6407 && gfc_compare_types (&expr1->ts, &expr2->ts)
6408 && !gfc_check_dependency (expr1, expr2, 0))
6410 tmp = gfc_trans_array_copy (expr1, expr2);
6415 /* Special case initializing an array from a constant array constructor. */
6416 if (copyable_array_p (expr1)
6417 && expr2->expr_type == EXPR_ARRAY
6418 && gfc_compare_types (&expr1->ts, &expr2->ts))
6420 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6425 /* Fallback to the scalarizer to generate explicit loops. */
6426 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6430 gfc_trans_init_assign (gfc_code * code)
6432 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6436 gfc_trans_assign (gfc_code * code)
6438 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6442 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6443 A MEMCPY is needed to copy the full data from the default initializer
6444 of the dynamic type. */
6447 gfc_trans_class_init_assign (gfc_code *code)
6451 gfc_se dst,src,memsz;
6452 gfc_expr *lhs,*rhs,*sz;
6454 gfc_start_block (&block);
6456 lhs = gfc_copy_expr (code->expr1);
6457 gfc_add_data_component (lhs);
6459 rhs = gfc_copy_expr (code->expr1);
6460 gfc_add_vptr_component (rhs);
6462 /* Make sure that the component backend_decls have been built, which
6463 will not have happened if the derived types concerned have not
6465 gfc_get_derived_type (rhs->ts.u.derived);
6466 gfc_add_def_init_component (rhs);
6468 sz = gfc_copy_expr (code->expr1);
6469 gfc_add_vptr_component (sz);
6470 gfc_add_size_component (sz);
6472 gfc_init_se (&dst, NULL);
6473 gfc_init_se (&src, NULL);
6474 gfc_init_se (&memsz, NULL);
6475 gfc_conv_expr (&dst, lhs);
6476 gfc_conv_expr (&src, rhs);
6477 gfc_conv_expr (&memsz, sz);
6478 gfc_add_block_to_block (&block, &src.pre);
6479 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6480 gfc_add_expr_to_block (&block, tmp);
6482 return gfc_finish_block (&block);
6486 /* Translate an assignment to a CLASS object
6487 (pointer or ordinary assignment). */
6490 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6497 gfc_start_block (&block);
6499 if (expr2->ts.type != BT_CLASS)
6501 /* Insert an additional assignment which sets the '_vptr' field. */
6502 gfc_symbol *vtab = NULL;
6505 lhs = gfc_copy_expr (expr1);
6506 gfc_add_vptr_component (lhs);
6508 if (expr2->ts.type == BT_DERIVED)
6509 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6510 else if (expr2->expr_type == EXPR_NULL)
6511 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6514 rhs = gfc_get_expr ();
6515 rhs->expr_type = EXPR_VARIABLE;
6516 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6520 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6521 gfc_add_expr_to_block (&block, tmp);
6523 gfc_free_expr (lhs);
6524 gfc_free_expr (rhs);
6527 /* Do the actual CLASS assignment. */
6528 if (expr2->ts.type == BT_CLASS)
6531 gfc_add_data_component (expr1);
6533 if (op == EXEC_ASSIGN)
6534 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6535 else if (op == EXEC_POINTER_ASSIGN)
6536 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6540 gfc_add_expr_to_block (&block, tmp);
6542 return gfc_finish_block (&block);