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)
619 tree parent_decl = NULL_TREE;
622 bool alternate_entry;
625 sym = expr->symtree->n.sym;
629 gfc_ss_info *ss_info = ss->info;
631 /* Check that something hasn't gone horribly wrong. */
632 gcc_assert (ss != gfc_ss_terminator);
633 gcc_assert (ss_info->expr == expr);
635 /* A scalarized term. We already know the descriptor. */
636 se->expr = se->ss->data.info.descriptor;
637 se->string_length = ss_info->string_length;
638 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
639 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
644 tree se_expr = NULL_TREE;
646 se->expr = gfc_get_symbol_decl (sym);
648 /* Deal with references to a parent results or entries by storing
649 the current_function_decl and moving to the parent_decl. */
650 return_value = sym->attr.function && sym->result == sym;
651 alternate_entry = sym->attr.function && sym->attr.entry
652 && sym->result == sym;
653 entry_master = sym->attr.result
654 && sym->ns->proc_name->attr.entry_master
655 && !gfc_return_by_reference (sym->ns->proc_name);
656 if (current_function_decl)
657 parent_decl = DECL_CONTEXT (current_function_decl);
659 if ((se->expr == parent_decl && return_value)
660 || (sym->ns && sym->ns->proc_name
662 && sym->ns->proc_name->backend_decl == parent_decl
663 && (alternate_entry || entry_master)))
668 /* Special case for assigning the return value of a function.
669 Self recursive functions must have an explicit return value. */
670 if (return_value && (se->expr == current_function_decl || parent_flag))
671 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
673 /* Similarly for alternate entry points. */
674 else if (alternate_entry
675 && (sym->ns->proc_name->backend_decl == current_function_decl
678 gfc_entry_list *el = NULL;
680 for (el = sym->ns->entries; el; el = el->next)
683 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
688 else if (entry_master
689 && (sym->ns->proc_name->backend_decl == current_function_decl
691 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
696 /* Procedure actual arguments. */
697 else if (sym->attr.flavor == FL_PROCEDURE
698 && se->expr != current_function_decl)
700 if (!sym->attr.dummy && !sym->attr.proc_pointer)
702 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
703 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
709 /* Dereference the expression, where needed. Since characters
710 are entirely different from other types, they are treated
712 if (sym->ts.type == BT_CHARACTER)
714 /* Dereference character pointer dummy arguments
716 if ((sym->attr.pointer || sym->attr.allocatable)
718 || sym->attr.function
719 || sym->attr.result))
720 se->expr = build_fold_indirect_ref_loc (input_location,
724 else if (!sym->attr.value)
726 /* Dereference non-character scalar dummy arguments. */
727 if (sym->attr.dummy && !sym->attr.dimension
728 && !(sym->attr.codimension && sym->attr.allocatable))
729 se->expr = build_fold_indirect_ref_loc (input_location,
732 /* Dereference scalar hidden result. */
733 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
734 && (sym->attr.function || sym->attr.result)
735 && !sym->attr.dimension && !sym->attr.pointer
736 && !sym->attr.always_explicit)
737 se->expr = build_fold_indirect_ref_loc (input_location,
740 /* Dereference non-character pointer variables.
741 These must be dummies, results, or scalars. */
742 if ((sym->attr.pointer || sym->attr.allocatable
743 || gfc_is_associate_pointer (sym))
745 || sym->attr.function
747 || (!sym->attr.dimension
748 && (!sym->attr.codimension || !sym->attr.allocatable))))
749 se->expr = build_fold_indirect_ref_loc (input_location,
756 /* For character variables, also get the length. */
757 if (sym->ts.type == BT_CHARACTER)
759 /* If the character length of an entry isn't set, get the length from
760 the master function instead. */
761 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
762 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
764 se->string_length = sym->ts.u.cl->backend_decl;
765 gcc_assert (se->string_length);
773 /* Return the descriptor if that's what we want and this is an array
774 section reference. */
775 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
777 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
778 /* Return the descriptor for array pointers and allocations. */
780 && ref->next == NULL && (se->descriptor_only))
783 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
784 /* Return a pointer to an element. */
788 if (ref->u.c.sym->attr.extension)
789 conv_parent_component_references (se, ref);
791 gfc_conv_component_ref (se, ref);
795 gfc_conv_substring (se, ref, expr->ts.kind,
796 expr->symtree->name, &expr->where);
805 /* Pointer assignment, allocation or pass by reference. Arrays are handled
807 if (se->want_pointer)
809 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
810 gfc_conv_string_parameter (se);
812 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
817 /* Unary ops are easy... Or they would be if ! was a valid op. */
820 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
825 gcc_assert (expr->ts.type != BT_CHARACTER);
826 /* Initialize the operand. */
827 gfc_init_se (&operand, se);
828 gfc_conv_expr_val (&operand, expr->value.op.op1);
829 gfc_add_block_to_block (&se->pre, &operand.pre);
831 type = gfc_typenode_for_spec (&expr->ts);
833 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
834 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
835 All other unary operators have an equivalent GIMPLE unary operator. */
836 if (code == TRUTH_NOT_EXPR)
837 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
838 build_int_cst (type, 0));
840 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
844 /* Expand power operator to optimal multiplications when a value is raised
845 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
846 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
847 Programming", 3rd Edition, 1998. */
849 /* This code is mostly duplicated from expand_powi in the backend.
850 We establish the "optimal power tree" lookup table with the defined size.
851 The items in the table are the exponents used to calculate the index
852 exponents. Any integer n less than the value can get an "addition chain",
853 with the first node being one. */
854 #define POWI_TABLE_SIZE 256
856 /* The table is from builtins.c. */
857 static const unsigned char powi_table[POWI_TABLE_SIZE] =
859 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
860 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
861 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
862 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
863 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
864 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
865 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
866 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
867 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
868 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
869 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
870 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
871 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
872 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
873 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
874 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
875 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
876 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
877 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
878 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
879 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
880 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
881 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
882 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
883 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
884 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
885 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
886 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
887 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
888 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
889 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
890 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
893 /* If n is larger than lookup table's max index, we use the "window
895 #define POWI_WINDOW_SIZE 3
897 /* Recursive function to expand the power operator. The temporary
898 values are put in tmpvar. The function returns tmpvar[1] ** n. */
900 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
907 if (n < POWI_TABLE_SIZE)
912 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
913 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
917 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
918 op0 = gfc_conv_powi (se, n - digit, tmpvar);
919 op1 = gfc_conv_powi (se, digit, tmpvar);
923 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
927 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
928 tmp = gfc_evaluate_now (tmp, &se->pre);
930 if (n < POWI_TABLE_SIZE)
937 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
938 return 1. Else return 0 and a call to runtime library functions
939 will have to be built. */
941 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
946 tree vartmp[POWI_TABLE_SIZE];
948 unsigned HOST_WIDE_INT n;
951 /* If exponent is too large, we won't expand it anyway, so don't bother
952 with large integer values. */
953 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
956 m = double_int_to_shwi (TREE_INT_CST (rhs));
957 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
958 of the asymmetric range of the integer type. */
959 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
961 type = TREE_TYPE (lhs);
962 sgn = tree_int_cst_sgn (rhs);
964 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
965 || optimize_size) && (m > 2 || m < -1))
971 se->expr = gfc_build_const (type, integer_one_node);
975 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
976 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
978 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
979 lhs, build_int_cst (TREE_TYPE (lhs), -1));
980 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
981 lhs, build_int_cst (TREE_TYPE (lhs), 1));
984 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
987 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
988 boolean_type_node, tmp, cond);
989 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
990 tmp, build_int_cst (type, 1),
991 build_int_cst (type, 0));
995 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
996 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
997 build_int_cst (type, -1),
998 build_int_cst (type, 0));
999 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1000 cond, build_int_cst (type, 1), tmp);
1004 memset (vartmp, 0, sizeof (vartmp));
1008 tmp = gfc_build_const (type, integer_one_node);
1009 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1013 se->expr = gfc_conv_powi (se, n, vartmp);
1019 /* Power op (**). Constant integer exponent has special handling. */
1022 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1024 tree gfc_int4_type_node;
1027 int res_ikind_1, res_ikind_2;
1032 gfc_init_se (&lse, se);
1033 gfc_conv_expr_val (&lse, expr->value.op.op1);
1034 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1035 gfc_add_block_to_block (&se->pre, &lse.pre);
1037 gfc_init_se (&rse, se);
1038 gfc_conv_expr_val (&rse, expr->value.op.op2);
1039 gfc_add_block_to_block (&se->pre, &rse.pre);
1041 if (expr->value.op.op2->ts.type == BT_INTEGER
1042 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1043 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1046 gfc_int4_type_node = gfc_get_int_type (4);
1048 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1049 library routine. But in the end, we have to convert the result back
1050 if this case applies -- with res_ikind_K, we keep track whether operand K
1051 falls into this case. */
1055 kind = expr->value.op.op1->ts.kind;
1056 switch (expr->value.op.op2->ts.type)
1059 ikind = expr->value.op.op2->ts.kind;
1064 rse.expr = convert (gfc_int4_type_node, rse.expr);
1065 res_ikind_2 = ikind;
1087 if (expr->value.op.op1->ts.type == BT_INTEGER)
1089 lse.expr = convert (gfc_int4_type_node, lse.expr);
1116 switch (expr->value.op.op1->ts.type)
1119 if (kind == 3) /* Case 16 was not handled properly above. */
1121 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1125 /* Use builtins for real ** int4. */
1131 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
1135 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1139 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1143 /* Use the __builtin_powil() only if real(kind=16) is
1144 actually the C long double type. */
1145 if (!gfc_real16_is_float128)
1146 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1154 /* If we don't have a good builtin for this, go for the
1155 library function. */
1157 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1161 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1170 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1174 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1182 se->expr = build_call_expr_loc (input_location,
1183 fndecl, 2, lse.expr, rse.expr);
1185 /* Convert the result back if it is of wrong integer kind. */
1186 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1188 /* We want the maximum of both operand kinds as result. */
1189 if (res_ikind_1 < res_ikind_2)
1190 res_ikind_1 = res_ikind_2;
1191 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1196 /* Generate code to allocate a string temporary. */
1199 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1204 if (gfc_can_put_var_on_stack (len))
1206 /* Create a temporary variable to hold the result. */
1207 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1208 gfc_charlen_type_node, len,
1209 build_int_cst (gfc_charlen_type_node, 1));
1210 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1212 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1213 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1215 tmp = build_array_type (TREE_TYPE (type), tmp);
1217 var = gfc_create_var (tmp, "str");
1218 var = gfc_build_addr_expr (type, var);
1222 /* Allocate a temporary to hold the result. */
1223 var = gfc_create_var (type, "pstr");
1224 tmp = gfc_call_malloc (&se->pre, type,
1225 fold_build2_loc (input_location, MULT_EXPR,
1226 TREE_TYPE (len), len,
1227 fold_convert (TREE_TYPE (len),
1228 TYPE_SIZE (type))));
1229 gfc_add_modify (&se->pre, var, tmp);
1231 /* Free the temporary afterwards. */
1232 tmp = gfc_call_free (convert (pvoid_type_node, var));
1233 gfc_add_expr_to_block (&se->post, tmp);
1240 /* Handle a string concatenation operation. A temporary will be allocated to
1244 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1247 tree len, type, var, tmp, fndecl;
1249 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1250 && expr->value.op.op2->ts.type == BT_CHARACTER);
1251 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1253 gfc_init_se (&lse, se);
1254 gfc_conv_expr (&lse, expr->value.op.op1);
1255 gfc_conv_string_parameter (&lse);
1256 gfc_init_se (&rse, se);
1257 gfc_conv_expr (&rse, expr->value.op.op2);
1258 gfc_conv_string_parameter (&rse);
1260 gfc_add_block_to_block (&se->pre, &lse.pre);
1261 gfc_add_block_to_block (&se->pre, &rse.pre);
1263 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1264 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1265 if (len == NULL_TREE)
1267 len = fold_build2_loc (input_location, PLUS_EXPR,
1268 TREE_TYPE (lse.string_length),
1269 lse.string_length, rse.string_length);
1272 type = build_pointer_type (type);
1274 var = gfc_conv_string_tmp (se, type, len);
1276 /* Do the actual concatenation. */
1277 if (expr->ts.kind == 1)
1278 fndecl = gfor_fndecl_concat_string;
1279 else if (expr->ts.kind == 4)
1280 fndecl = gfor_fndecl_concat_string_char4;
1284 tmp = build_call_expr_loc (input_location,
1285 fndecl, 6, len, var, lse.string_length, lse.expr,
1286 rse.string_length, rse.expr);
1287 gfc_add_expr_to_block (&se->pre, tmp);
1289 /* Add the cleanup for the operands. */
1290 gfc_add_block_to_block (&se->pre, &rse.post);
1291 gfc_add_block_to_block (&se->pre, &lse.post);
1294 se->string_length = len;
1297 /* Translates an op expression. Common (binary) cases are handled by this
1298 function, others are passed on. Recursion is used in either case.
1299 We use the fact that (op1.ts == op2.ts) (except for the power
1301 Operators need no special handling for scalarized expressions as long as
1302 they call gfc_conv_simple_val to get their operands.
1303 Character strings get special handling. */
1306 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1308 enum tree_code code;
1317 switch (expr->value.op.op)
1319 case INTRINSIC_PARENTHESES:
1320 if ((expr->ts.type == BT_REAL
1321 || expr->ts.type == BT_COMPLEX)
1322 && gfc_option.flag_protect_parens)
1324 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1325 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1330 case INTRINSIC_UPLUS:
1331 gfc_conv_expr (se, expr->value.op.op1);
1334 case INTRINSIC_UMINUS:
1335 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1339 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1342 case INTRINSIC_PLUS:
1346 case INTRINSIC_MINUS:
1350 case INTRINSIC_TIMES:
1354 case INTRINSIC_DIVIDE:
1355 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1356 an integer, we must round towards zero, so we use a
1358 if (expr->ts.type == BT_INTEGER)
1359 code = TRUNC_DIV_EXPR;
1364 case INTRINSIC_POWER:
1365 gfc_conv_power_op (se, expr);
1368 case INTRINSIC_CONCAT:
1369 gfc_conv_concat_op (se, expr);
1373 code = TRUTH_ANDIF_EXPR;
1378 code = TRUTH_ORIF_EXPR;
1382 /* EQV and NEQV only work on logicals, but since we represent them
1383 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1385 case INTRINSIC_EQ_OS:
1393 case INTRINSIC_NE_OS:
1394 case INTRINSIC_NEQV:
1401 case INTRINSIC_GT_OS:
1408 case INTRINSIC_GE_OS:
1415 case INTRINSIC_LT_OS:
1422 case INTRINSIC_LE_OS:
1428 case INTRINSIC_USER:
1429 case INTRINSIC_ASSIGN:
1430 /* These should be converted into function calls by the frontend. */
1434 fatal_error ("Unknown intrinsic op");
1438 /* The only exception to this is **, which is handled separately anyway. */
1439 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1441 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1445 gfc_init_se (&lse, se);
1446 gfc_conv_expr (&lse, expr->value.op.op1);
1447 gfc_add_block_to_block (&se->pre, &lse.pre);
1450 gfc_init_se (&rse, se);
1451 gfc_conv_expr (&rse, expr->value.op.op2);
1452 gfc_add_block_to_block (&se->pre, &rse.pre);
1456 gfc_conv_string_parameter (&lse);
1457 gfc_conv_string_parameter (&rse);
1459 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1460 rse.string_length, rse.expr,
1461 expr->value.op.op1->ts.kind,
1463 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1464 gfc_add_block_to_block (&lse.post, &rse.post);
1467 type = gfc_typenode_for_spec (&expr->ts);
1471 /* The result of logical ops is always boolean_type_node. */
1472 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1473 lse.expr, rse.expr);
1474 se->expr = convert (type, tmp);
1477 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1479 /* Add the post blocks. */
1480 gfc_add_block_to_block (&se->post, &rse.post);
1481 gfc_add_block_to_block (&se->post, &lse.post);
1484 /* If a string's length is one, we convert it to a single character. */
1487 gfc_string_to_single_character (tree len, tree str, int kind)
1490 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1491 || !POINTER_TYPE_P (TREE_TYPE (str)))
1494 if (TREE_INT_CST_LOW (len) == 1)
1496 str = fold_convert (gfc_get_pchar_type (kind), str);
1497 return build_fold_indirect_ref_loc (input_location, str);
1501 && TREE_CODE (str) == ADDR_EXPR
1502 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1503 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1504 && array_ref_low_bound (TREE_OPERAND (str, 0))
1505 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1506 && TREE_INT_CST_LOW (len) > 1
1507 && TREE_INT_CST_LOW (len)
1508 == (unsigned HOST_WIDE_INT)
1509 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1511 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1512 ret = build_fold_indirect_ref_loc (input_location, ret);
1513 if (TREE_CODE (ret) == INTEGER_CST)
1515 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1516 int i, length = TREE_STRING_LENGTH (string_cst);
1517 const char *ptr = TREE_STRING_POINTER (string_cst);
1519 for (i = 1; i < length; i++)
1532 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1535 if (sym->backend_decl)
1537 /* This becomes the nominal_type in
1538 function.c:assign_parm_find_data_types. */
1539 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1540 /* This becomes the passed_type in
1541 function.c:assign_parm_find_data_types. C promotes char to
1542 integer for argument passing. */
1543 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1545 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1550 /* If we have a constant character expression, make it into an
1552 if ((*expr)->expr_type == EXPR_CONSTANT)
1557 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1558 (int)(*expr)->value.character.string[0]);
1559 if ((*expr)->ts.kind != gfc_c_int_kind)
1561 /* The expr needs to be compatible with a C int. If the
1562 conversion fails, then the 2 causes an ICE. */
1563 ts.type = BT_INTEGER;
1564 ts.kind = gfc_c_int_kind;
1565 gfc_convert_type (*expr, &ts, 2);
1568 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1570 if ((*expr)->ref == NULL)
1572 se->expr = gfc_string_to_single_character
1573 (build_int_cst (integer_type_node, 1),
1574 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1576 ((*expr)->symtree->n.sym)),
1581 gfc_conv_variable (se, *expr);
1582 se->expr = gfc_string_to_single_character
1583 (build_int_cst (integer_type_node, 1),
1584 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1592 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1593 if STR is a string literal, otherwise return -1. */
1596 gfc_optimize_len_trim (tree len, tree str, int kind)
1599 && TREE_CODE (str) == ADDR_EXPR
1600 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1601 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1602 && array_ref_low_bound (TREE_OPERAND (str, 0))
1603 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1604 && TREE_INT_CST_LOW (len) >= 1
1605 && TREE_INT_CST_LOW (len)
1606 == (unsigned HOST_WIDE_INT)
1607 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1609 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1610 folded = build_fold_indirect_ref_loc (input_location, folded);
1611 if (TREE_CODE (folded) == INTEGER_CST)
1613 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1614 int length = TREE_STRING_LENGTH (string_cst);
1615 const char *ptr = TREE_STRING_POINTER (string_cst);
1617 for (; length > 0; length--)
1618 if (ptr[length - 1] != ' ')
1627 /* Compare two strings. If they are all single characters, the result is the
1628 subtraction of them. Otherwise, we build a library call. */
1631 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1632 enum tree_code code)
1638 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1639 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1641 sc1 = gfc_string_to_single_character (len1, str1, kind);
1642 sc2 = gfc_string_to_single_character (len2, str2, kind);
1644 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1646 /* Deal with single character specially. */
1647 sc1 = fold_convert (integer_type_node, sc1);
1648 sc2 = fold_convert (integer_type_node, sc2);
1649 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1653 if ((code == EQ_EXPR || code == NE_EXPR)
1655 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1657 /* If one string is a string literal with LEN_TRIM longer
1658 than the length of the second string, the strings
1660 int len = gfc_optimize_len_trim (len1, str1, kind);
1661 if (len > 0 && compare_tree_int (len2, len) < 0)
1662 return integer_one_node;
1663 len = gfc_optimize_len_trim (len2, str2, kind);
1664 if (len > 0 && compare_tree_int (len1, len) < 0)
1665 return integer_one_node;
1668 /* Build a call for the comparison. */
1670 fndecl = gfor_fndecl_compare_string;
1672 fndecl = gfor_fndecl_compare_string_char4;
1676 return build_call_expr_loc (input_location, fndecl, 4,
1677 len1, str1, len2, str2);
1681 /* Return the backend_decl for a procedure pointer component. */
1684 get_proc_ptr_comp (gfc_expr *e)
1690 gfc_init_se (&comp_se, NULL);
1691 e2 = gfc_copy_expr (e);
1692 /* We have to restore the expr type later so that gfc_free_expr frees
1693 the exact same thing that was allocated.
1694 TODO: This is ugly. */
1695 old_type = e2->expr_type;
1696 e2->expr_type = EXPR_VARIABLE;
1697 gfc_conv_expr (&comp_se, e2);
1698 e2->expr_type = old_type;
1700 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1705 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1709 if (gfc_is_proc_ptr_comp (expr, NULL))
1710 tmp = get_proc_ptr_comp (expr);
1711 else if (sym->attr.dummy)
1713 tmp = gfc_get_symbol_decl (sym);
1714 if (sym->attr.proc_pointer)
1715 tmp = build_fold_indirect_ref_loc (input_location,
1717 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1718 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1722 if (!sym->backend_decl)
1723 sym->backend_decl = gfc_get_extern_function_decl (sym);
1725 tmp = sym->backend_decl;
1727 if (sym->attr.cray_pointee)
1729 /* TODO - make the cray pointee a pointer to a procedure,
1730 assign the pointer to it and use it for the call. This
1732 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1733 gfc_get_symbol_decl (sym->cp_pointer));
1734 tmp = gfc_evaluate_now (tmp, &se->pre);
1737 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1739 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1740 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1747 /* Initialize MAPPING. */
1750 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1752 mapping->syms = NULL;
1753 mapping->charlens = NULL;
1757 /* Free all memory held by MAPPING (but not MAPPING itself). */
1760 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1762 gfc_interface_sym_mapping *sym;
1763 gfc_interface_sym_mapping *nextsym;
1765 gfc_charlen *nextcl;
1767 for (sym = mapping->syms; sym; sym = nextsym)
1769 nextsym = sym->next;
1770 sym->new_sym->n.sym->formal = NULL;
1771 gfc_free_symbol (sym->new_sym->n.sym);
1772 gfc_free_expr (sym->expr);
1773 free (sym->new_sym);
1776 for (cl = mapping->charlens; cl; cl = nextcl)
1779 gfc_free_expr (cl->length);
1785 /* Return a copy of gfc_charlen CL. Add the returned structure to
1786 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1788 static gfc_charlen *
1789 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1792 gfc_charlen *new_charlen;
1794 new_charlen = gfc_get_charlen ();
1795 new_charlen->next = mapping->charlens;
1796 new_charlen->length = gfc_copy_expr (cl->length);
1798 mapping->charlens = new_charlen;
1803 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1804 array variable that can be used as the actual argument for dummy
1805 argument SYM. Add any initialization code to BLOCK. PACKED is as
1806 for gfc_get_nodesc_array_type and DATA points to the first element
1807 in the passed array. */
1810 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1811 gfc_packed packed, tree data)
1816 type = gfc_typenode_for_spec (&sym->ts);
1817 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1818 !sym->attr.target && !sym->attr.pointer
1819 && !sym->attr.proc_pointer);
1821 var = gfc_create_var (type, "ifm");
1822 gfc_add_modify (block, var, fold_convert (type, data));
1828 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1829 and offset of descriptorless array type TYPE given that it has the same
1830 size as DESC. Add any set-up code to BLOCK. */
1833 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1840 offset = gfc_index_zero_node;
1841 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1843 dim = gfc_rank_cst[n];
1844 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1845 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1847 GFC_TYPE_ARRAY_LBOUND (type, n)
1848 = gfc_conv_descriptor_lbound_get (desc, dim);
1849 GFC_TYPE_ARRAY_UBOUND (type, n)
1850 = gfc_conv_descriptor_ubound_get (desc, dim);
1852 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1854 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1855 gfc_array_index_type,
1856 gfc_conv_descriptor_ubound_get (desc, dim),
1857 gfc_conv_descriptor_lbound_get (desc, dim));
1858 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1859 gfc_array_index_type,
1860 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1861 tmp = gfc_evaluate_now (tmp, block);
1862 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1864 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1865 GFC_TYPE_ARRAY_LBOUND (type, n),
1866 GFC_TYPE_ARRAY_STRIDE (type, n));
1867 offset = fold_build2_loc (input_location, MINUS_EXPR,
1868 gfc_array_index_type, offset, tmp);
1870 offset = gfc_evaluate_now (offset, block);
1871 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1875 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1876 in SE. The caller may still use se->expr and se->string_length after
1877 calling this function. */
1880 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1881 gfc_symbol * sym, gfc_se * se,
1884 gfc_interface_sym_mapping *sm;
1888 gfc_symbol *new_sym;
1890 gfc_symtree *new_symtree;
1892 /* Create a new symbol to represent the actual argument. */
1893 new_sym = gfc_new_symbol (sym->name, NULL);
1894 new_sym->ts = sym->ts;
1895 new_sym->as = gfc_copy_array_spec (sym->as);
1896 new_sym->attr.referenced = 1;
1897 new_sym->attr.dimension = sym->attr.dimension;
1898 new_sym->attr.contiguous = sym->attr.contiguous;
1899 new_sym->attr.codimension = sym->attr.codimension;
1900 new_sym->attr.pointer = sym->attr.pointer;
1901 new_sym->attr.allocatable = sym->attr.allocatable;
1902 new_sym->attr.flavor = sym->attr.flavor;
1903 new_sym->attr.function = sym->attr.function;
1905 /* Ensure that the interface is available and that
1906 descriptors are passed for array actual arguments. */
1907 if (sym->attr.flavor == FL_PROCEDURE)
1909 new_sym->formal = expr->symtree->n.sym->formal;
1910 new_sym->attr.always_explicit
1911 = expr->symtree->n.sym->attr.always_explicit;
1914 /* Create a fake symtree for it. */
1916 new_symtree = gfc_new_symtree (&root, sym->name);
1917 new_symtree->n.sym = new_sym;
1918 gcc_assert (new_symtree == root);
1920 /* Create a dummy->actual mapping. */
1921 sm = XCNEW (gfc_interface_sym_mapping);
1922 sm->next = mapping->syms;
1924 sm->new_sym = new_symtree;
1925 sm->expr = gfc_copy_expr (expr);
1928 /* Stabilize the argument's value. */
1929 if (!sym->attr.function && se)
1930 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1932 if (sym->ts.type == BT_CHARACTER)
1934 /* Create a copy of the dummy argument's length. */
1935 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1936 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1938 /* If the length is specified as "*", record the length that
1939 the caller is passing. We should use the callee's length
1940 in all other cases. */
1941 if (!new_sym->ts.u.cl->length && se)
1943 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1944 new_sym->ts.u.cl->backend_decl = se->string_length;
1951 /* Use the passed value as-is if the argument is a function. */
1952 if (sym->attr.flavor == FL_PROCEDURE)
1955 /* If the argument is either a string or a pointer to a string,
1956 convert it to a boundless character type. */
1957 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1959 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1960 tmp = build_pointer_type (tmp);
1961 if (sym->attr.pointer)
1962 value = build_fold_indirect_ref_loc (input_location,
1966 value = fold_convert (tmp, value);
1969 /* If the argument is a scalar, a pointer to an array or an allocatable,
1971 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1972 value = build_fold_indirect_ref_loc (input_location,
1975 /* For character(*), use the actual argument's descriptor. */
1976 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1977 value = build_fold_indirect_ref_loc (input_location,
1980 /* If the argument is an array descriptor, use it to determine
1981 information about the actual argument's shape. */
1982 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1983 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1985 /* Get the actual argument's descriptor. */
1986 desc = build_fold_indirect_ref_loc (input_location,
1989 /* Create the replacement variable. */
1990 tmp = gfc_conv_descriptor_data_get (desc);
1991 value = gfc_get_interface_mapping_array (&se->pre, sym,
1994 /* Use DESC to work out the upper bounds, strides and offset. */
1995 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1998 /* Otherwise we have a packed array. */
1999 value = gfc_get_interface_mapping_array (&se->pre, sym,
2000 PACKED_FULL, se->expr);
2002 new_sym->backend_decl = value;
2006 /* Called once all dummy argument mappings have been added to MAPPING,
2007 but before the mapping is used to evaluate expressions. Pre-evaluate
2008 the length of each argument, adding any initialization code to PRE and
2009 any finalization code to POST. */
2012 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2013 stmtblock_t * pre, stmtblock_t * post)
2015 gfc_interface_sym_mapping *sym;
2019 for (sym = mapping->syms; sym; sym = sym->next)
2020 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2021 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2023 expr = sym->new_sym->n.sym->ts.u.cl->length;
2024 gfc_apply_interface_mapping_to_expr (mapping, expr);
2025 gfc_init_se (&se, NULL);
2026 gfc_conv_expr (&se, expr);
2027 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2028 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2029 gfc_add_block_to_block (pre, &se.pre);
2030 gfc_add_block_to_block (post, &se.post);
2032 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2037 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2041 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2042 gfc_constructor_base base)
2045 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2047 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2050 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2051 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2052 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2058 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2062 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2067 for (; ref; ref = ref->next)
2071 for (n = 0; n < ref->u.ar.dimen; n++)
2073 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2074 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2075 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2077 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2084 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2085 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2091 /* Convert intrinsic function calls into result expressions. */
2094 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2102 arg1 = expr->value.function.actual->expr;
2103 if (expr->value.function.actual->next)
2104 arg2 = expr->value.function.actual->next->expr;
2108 sym = arg1->symtree->n.sym;
2110 if (sym->attr.dummy)
2115 switch (expr->value.function.isym->id)
2118 /* TODO figure out why this condition is necessary. */
2119 if (sym->attr.function
2120 && (arg1->ts.u.cl->length == NULL
2121 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2122 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2125 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2129 if (!sym->as || sym->as->rank == 0)
2132 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2134 dup = mpz_get_si (arg2->value.integer);
2139 dup = sym->as->rank;
2143 for (; d < dup; d++)
2147 if (!sym->as->upper[d] || !sym->as->lower[d])
2149 gfc_free_expr (new_expr);
2153 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2154 gfc_get_int_expr (gfc_default_integer_kind,
2156 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2158 new_expr = gfc_multiply (new_expr, tmp);
2164 case GFC_ISYM_LBOUND:
2165 case GFC_ISYM_UBOUND:
2166 /* TODO These implementations of lbound and ubound do not limit if
2167 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2169 if (!sym->as || sym->as->rank == 0)
2172 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2173 d = mpz_get_si (arg2->value.integer) - 1;
2175 /* TODO: If the need arises, this could produce an array of
2179 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2181 if (sym->as->lower[d])
2182 new_expr = gfc_copy_expr (sym->as->lower[d]);
2186 if (sym->as->upper[d])
2187 new_expr = gfc_copy_expr (sym->as->upper[d]);
2195 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2199 gfc_replace_expr (expr, new_expr);
2205 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2206 gfc_interface_mapping * mapping)
2208 gfc_formal_arglist *f;
2209 gfc_actual_arglist *actual;
2211 actual = expr->value.function.actual;
2212 f = map_expr->symtree->n.sym->formal;
2214 for (; f && actual; f = f->next, actual = actual->next)
2219 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2222 if (map_expr->symtree->n.sym->attr.dimension)
2227 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2229 for (d = 0; d < as->rank; d++)
2231 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2232 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2235 expr->value.function.esym->as = as;
2238 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2240 expr->value.function.esym->ts.u.cl->length
2241 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2243 gfc_apply_interface_mapping_to_expr (mapping,
2244 expr->value.function.esym->ts.u.cl->length);
2249 /* EXPR is a copy of an expression that appeared in the interface
2250 associated with MAPPING. Walk it recursively looking for references to
2251 dummy arguments that MAPPING maps to actual arguments. Replace each such
2252 reference with a reference to the associated actual argument. */
2255 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2258 gfc_interface_sym_mapping *sym;
2259 gfc_actual_arglist *actual;
2264 /* Copying an expression does not copy its length, so do that here. */
2265 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2267 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2268 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2271 /* Apply the mapping to any references. */
2272 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2274 /* ...and to the expression's symbol, if it has one. */
2275 /* TODO Find out why the condition on expr->symtree had to be moved into
2276 the loop rather than being outside it, as originally. */
2277 for (sym = mapping->syms; sym; sym = sym->next)
2278 if (expr->symtree && sym->old == expr->symtree->n.sym)
2280 if (sym->new_sym->n.sym->backend_decl)
2281 expr->symtree = sym->new_sym;
2283 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2284 /* Replace base type for polymorphic arguments. */
2285 if (expr->ref && expr->ref->type == REF_COMPONENT
2286 && sym->expr && sym->expr->ts.type == BT_CLASS)
2287 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2290 /* ...and to subexpressions in expr->value. */
2291 switch (expr->expr_type)
2296 case EXPR_SUBSTRING:
2300 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2301 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2305 for (actual = expr->value.function.actual; actual; actual = actual->next)
2306 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2308 if (expr->value.function.esym == NULL
2309 && expr->value.function.isym != NULL
2310 && expr->value.function.actual->expr->symtree
2311 && gfc_map_intrinsic_function (expr, mapping))
2314 for (sym = mapping->syms; sym; sym = sym->next)
2315 if (sym->old == expr->value.function.esym)
2317 expr->value.function.esym = sym->new_sym->n.sym;
2318 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2319 expr->value.function.esym->result = sym->new_sym->n.sym;
2324 case EXPR_STRUCTURE:
2325 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2338 /* Evaluate interface expression EXPR using MAPPING. Store the result
2342 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2343 gfc_se * se, gfc_expr * expr)
2345 expr = gfc_copy_expr (expr);
2346 gfc_apply_interface_mapping_to_expr (mapping, expr);
2347 gfc_conv_expr (se, expr);
2348 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2349 gfc_free_expr (expr);
2353 /* Returns a reference to a temporary array into which a component of
2354 an actual argument derived type array is copied and then returned
2355 after the function call. */
2357 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2358 sym_intent intent, bool formal_ptr)
2366 gfc_array_info *info;
2376 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2378 gfc_init_se (&lse, NULL);
2379 gfc_init_se (&rse, NULL);
2381 /* Walk the argument expression. */
2382 rss = gfc_walk_expr (expr);
2384 gcc_assert (rss != gfc_ss_terminator);
2386 /* Initialize the scalarizer. */
2387 gfc_init_loopinfo (&loop);
2388 gfc_add_ss_to_loop (&loop, rss);
2390 /* Calculate the bounds of the scalarization. */
2391 gfc_conv_ss_startstride (&loop);
2393 /* Build an ss for the temporary. */
2394 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2395 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2397 base_type = gfc_typenode_for_spec (&expr->ts);
2398 if (GFC_ARRAY_TYPE_P (base_type)
2399 || GFC_DESCRIPTOR_TYPE_P (base_type))
2400 base_type = gfc_get_element_type (base_type);
2402 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2403 ? expr->ts.u.cl->backend_decl
2407 parmse->string_length = loop.temp_ss->info->string_length;
2409 /* Associate the SS with the loop. */
2410 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2412 /* Setup the scalarizing loops. */
2413 gfc_conv_loop_setup (&loop, &expr->where);
2415 /* Pass the temporary descriptor back to the caller. */
2416 info = &loop.temp_ss->data.info;
2417 parmse->expr = info->descriptor;
2419 /* Setup the gfc_se structures. */
2420 gfc_copy_loopinfo_to_se (&lse, &loop);
2421 gfc_copy_loopinfo_to_se (&rse, &loop);
2424 lse.ss = loop.temp_ss;
2425 gfc_mark_ss_chain_used (rss, 1);
2426 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2428 /* Start the scalarized loop body. */
2429 gfc_start_scalarized_body (&loop, &body);
2431 /* Translate the expression. */
2432 gfc_conv_expr (&rse, expr);
2434 gfc_conv_tmp_array_ref (&lse);
2436 if (intent != INTENT_OUT)
2438 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2439 gfc_add_expr_to_block (&body, tmp);
2440 gcc_assert (rse.ss == gfc_ss_terminator);
2441 gfc_trans_scalarizing_loops (&loop, &body);
2445 /* Make sure that the temporary declaration survives by merging
2446 all the loop declarations into the current context. */
2447 for (n = 0; n < loop.dimen; n++)
2449 gfc_merge_block_scope (&body);
2450 body = loop.code[loop.order[n]];
2452 gfc_merge_block_scope (&body);
2455 /* Add the post block after the second loop, so that any
2456 freeing of allocated memory is done at the right time. */
2457 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2459 /**********Copy the temporary back again.*********/
2461 gfc_init_se (&lse, NULL);
2462 gfc_init_se (&rse, NULL);
2464 /* Walk the argument expression. */
2465 lss = gfc_walk_expr (expr);
2466 rse.ss = loop.temp_ss;
2469 /* Initialize the scalarizer. */
2470 gfc_init_loopinfo (&loop2);
2471 gfc_add_ss_to_loop (&loop2, lss);
2473 /* Calculate the bounds of the scalarization. */
2474 gfc_conv_ss_startstride (&loop2);
2476 /* Setup the scalarizing loops. */
2477 gfc_conv_loop_setup (&loop2, &expr->where);
2479 gfc_copy_loopinfo_to_se (&lse, &loop2);
2480 gfc_copy_loopinfo_to_se (&rse, &loop2);
2482 gfc_mark_ss_chain_used (lss, 1);
2483 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2485 /* Declare the variable to hold the temporary offset and start the
2486 scalarized loop body. */
2487 offset = gfc_create_var (gfc_array_index_type, NULL);
2488 gfc_start_scalarized_body (&loop2, &body);
2490 /* Build the offsets for the temporary from the loop variables. The
2491 temporary array has lbounds of zero and strides of one in all
2492 dimensions, so this is very simple. The offset is only computed
2493 outside the innermost loop, so the overall transfer could be
2494 optimized further. */
2495 info = &rse.ss->data.info;
2496 dimen = rse.ss->dimen;
2498 tmp_index = gfc_index_zero_node;
2499 for (n = dimen - 1; n > 0; n--)
2502 tmp = rse.loop->loopvar[n];
2503 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2504 tmp, rse.loop->from[n]);
2505 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2508 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2509 gfc_array_index_type,
2510 rse.loop->to[n-1], rse.loop->from[n-1]);
2511 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2512 gfc_array_index_type,
2513 tmp_str, gfc_index_one_node);
2515 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2516 gfc_array_index_type, tmp, tmp_str);
2519 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2520 gfc_array_index_type,
2521 tmp_index, rse.loop->from[0]);
2522 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2524 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2525 gfc_array_index_type,
2526 rse.loop->loopvar[0], offset);
2528 /* Now use the offset for the reference. */
2529 tmp = build_fold_indirect_ref_loc (input_location,
2531 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2533 if (expr->ts.type == BT_CHARACTER)
2534 rse.string_length = expr->ts.u.cl->backend_decl;
2536 gfc_conv_expr (&lse, expr);
2538 gcc_assert (lse.ss == gfc_ss_terminator);
2540 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2541 gfc_add_expr_to_block (&body, tmp);
2543 /* Generate the copying loops. */
2544 gfc_trans_scalarizing_loops (&loop2, &body);
2546 /* Wrap the whole thing up by adding the second loop to the post-block
2547 and following it by the post-block of the first loop. In this way,
2548 if the temporary needs freeing, it is done after use! */
2549 if (intent != INTENT_IN)
2551 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2552 gfc_add_block_to_block (&parmse->post, &loop2.post);
2555 gfc_add_block_to_block (&parmse->post, &loop.post);
2557 gfc_cleanup_loop (&loop);
2558 gfc_cleanup_loop (&loop2);
2560 /* Pass the string length to the argument expression. */
2561 if (expr->ts.type == BT_CHARACTER)
2562 parmse->string_length = expr->ts.u.cl->backend_decl;
2564 /* Determine the offset for pointer formal arguments and set the
2568 size = gfc_index_one_node;
2569 offset = gfc_index_zero_node;
2570 for (n = 0; n < dimen; n++)
2572 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2574 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2575 gfc_array_index_type, tmp,
2576 gfc_index_one_node);
2577 gfc_conv_descriptor_ubound_set (&parmse->pre,
2581 gfc_conv_descriptor_lbound_set (&parmse->pre,
2584 gfc_index_one_node);
2585 size = gfc_evaluate_now (size, &parmse->pre);
2586 offset = fold_build2_loc (input_location, MINUS_EXPR,
2587 gfc_array_index_type,
2589 offset = gfc_evaluate_now (offset, &parmse->pre);
2590 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2591 gfc_array_index_type,
2592 rse.loop->to[n], rse.loop->from[n]);
2593 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2594 gfc_array_index_type,
2595 tmp, gfc_index_one_node);
2596 size = fold_build2_loc (input_location, MULT_EXPR,
2597 gfc_array_index_type, size, tmp);
2600 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2604 /* We want either the address for the data or the address of the descriptor,
2605 depending on the mode of passing array arguments. */
2607 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2609 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2615 /* Generate the code for argument list functions. */
2618 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2620 /* Pass by value for g77 %VAL(arg), pass the address
2621 indirectly for %LOC, else by reference. Thus %REF
2622 is a "do-nothing" and %LOC is the same as an F95
2624 if (strncmp (name, "%VAL", 4) == 0)
2625 gfc_conv_expr (se, expr);
2626 else if (strncmp (name, "%LOC", 4) == 0)
2628 gfc_conv_expr_reference (se, expr);
2629 se->expr = gfc_build_addr_expr (NULL, se->expr);
2631 else if (strncmp (name, "%REF", 4) == 0)
2632 gfc_conv_expr_reference (se, expr);
2634 gfc_error ("Unknown argument list function at %L", &expr->where);
2638 /* Takes a derived type expression and returns the address of a temporary
2639 class object of the 'declared' type. */
2641 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2642 gfc_typespec class_ts)
2646 gfc_symbol *declared = class_ts.u.derived;
2652 /* The derived type needs to be converted to a temporary
2654 tmp = gfc_typenode_for_spec (&class_ts);
2655 var = gfc_create_var (tmp, "class");
2658 cmp = gfc_find_component (declared, "_vptr", true, true);
2659 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2660 TREE_TYPE (cmp->backend_decl),
2661 var, cmp->backend_decl, NULL_TREE);
2663 /* Remember the vtab corresponds to the derived type
2664 not to the class declared type. */
2665 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2667 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2668 gfc_add_modify (&parmse->pre, ctree,
2669 fold_convert (TREE_TYPE (ctree), tmp));
2671 /* Now set the data field. */
2672 cmp = gfc_find_component (declared, "_data", true, true);
2673 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2674 TREE_TYPE (cmp->backend_decl),
2675 var, cmp->backend_decl, NULL_TREE);
2676 ss = gfc_walk_expr (e);
2677 if (ss == gfc_ss_terminator)
2680 gfc_conv_expr_reference (parmse, e);
2681 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2682 gfc_add_modify (&parmse->pre, ctree, tmp);
2687 gfc_conv_expr (parmse, e);
2688 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2691 /* Pass the address of the class object. */
2692 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2696 /* The following routine generates code for the intrinsic
2697 procedures from the ISO_C_BINDING module:
2699 * C_FUNLOC (function)
2700 * C_F_POINTER (subroutine)
2701 * C_F_PROCPOINTER (subroutine)
2702 * C_ASSOCIATED (function)
2703 One exception which is not handled here is C_F_POINTER with non-scalar
2704 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2707 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2708 gfc_actual_arglist * arg)
2713 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2715 if (arg->expr->rank == 0)
2716 gfc_conv_expr_reference (se, arg->expr);
2720 /* This is really the actual arg because no formal arglist is
2721 created for C_LOC. */
2722 fsym = arg->expr->symtree->n.sym;
2724 /* We should want it to do g77 calling convention. */
2726 && !(fsym->attr.pointer || fsym->attr.allocatable)
2727 && fsym->as->type != AS_ASSUMED_SHAPE;
2728 f = f || !sym->attr.always_explicit;
2730 argss = gfc_walk_expr (arg->expr);
2731 gfc_conv_array_parameter (se, arg->expr, argss, f,
2735 /* TODO -- the following two lines shouldn't be necessary, but if
2736 they're removed, a bug is exposed later in the code path.
2737 This workaround was thus introduced, but will have to be
2738 removed; please see PR 35150 for details about the issue. */
2739 se->expr = convert (pvoid_type_node, se->expr);
2740 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2744 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2746 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2747 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2748 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2749 gfc_conv_expr_reference (se, arg->expr);
2753 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2754 && arg->next->expr->rank == 0)
2755 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2757 /* Convert c_f_pointer if fptr is a scalar
2758 and convert c_f_procpointer. */
2762 gfc_init_se (&cptrse, NULL);
2763 gfc_conv_expr (&cptrse, arg->expr);
2764 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2765 gfc_add_block_to_block (&se->post, &cptrse.post);
2767 gfc_init_se (&fptrse, NULL);
2768 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2769 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2770 fptrse.want_pointer = 1;
2772 gfc_conv_expr (&fptrse, arg->next->expr);
2773 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2774 gfc_add_block_to_block (&se->post, &fptrse.post);
2776 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2777 && arg->next->expr->symtree->n.sym->attr.dummy)
2778 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2781 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2782 TREE_TYPE (fptrse.expr),
2784 fold_convert (TREE_TYPE (fptrse.expr),
2789 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2794 /* Build the addr_expr for the first argument. The argument is
2795 already an *address* so we don't need to set want_pointer in
2797 gfc_init_se (&arg1se, NULL);
2798 gfc_conv_expr (&arg1se, arg->expr);
2799 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2800 gfc_add_block_to_block (&se->post, &arg1se.post);
2802 /* See if we were given two arguments. */
2803 if (arg->next == NULL)
2804 /* Only given one arg so generate a null and do a
2805 not-equal comparison against the first arg. */
2806 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2808 fold_convert (TREE_TYPE (arg1se.expr),
2809 null_pointer_node));
2815 /* Given two arguments so build the arg2se from second arg. */
2816 gfc_init_se (&arg2se, NULL);
2817 gfc_conv_expr (&arg2se, arg->next->expr);
2818 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2819 gfc_add_block_to_block (&se->post, &arg2se.post);
2821 /* Generate test to compare that the two args are equal. */
2822 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2823 arg1se.expr, arg2se.expr);
2824 /* Generate test to ensure that the first arg is not null. */
2825 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2827 arg1se.expr, null_pointer_node);
2829 /* Finally, the generated test must check that both arg1 is not
2830 NULL and that it is equal to the second arg. */
2831 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2833 not_null_expr, eq_expr);
2839 /* Nothing was done. */
2844 /* Generate code for a procedure call. Note can return se->post != NULL.
2845 If se->direct_byref is set then se->expr contains the return parameter.
2846 Return nonzero, if the call has alternate specifiers.
2847 'expr' is only needed for procedure pointer components. */
2850 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2851 gfc_actual_arglist * args, gfc_expr * expr,
2852 VEC(tree,gc) *append_args)
2854 gfc_interface_mapping mapping;
2855 VEC(tree,gc) *arglist;
2856 VEC(tree,gc) *retargs;
2861 gfc_array_info *info;
2867 VEC(tree,gc) *stringargs;
2869 gfc_formal_arglist *formal;
2870 gfc_actual_arglist *arg;
2871 int has_alternate_specifier = 0;
2872 bool need_interface_mapping;
2879 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2880 gfc_component *comp = NULL;
2890 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2891 && conv_isocbinding_procedure (se, sym, args))
2894 gfc_is_proc_ptr_comp (expr, &comp);
2898 if (!sym->attr.elemental)
2900 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
2901 if (se->ss->useflags)
2903 gcc_assert ((!comp && gfc_return_by_reference (sym)
2904 && sym->result->attr.dimension)
2905 || (comp && comp->attr.dimension));
2906 gcc_assert (se->loop != NULL);
2908 /* Access the previously obtained result. */
2909 gfc_conv_tmp_array_ref (se);
2913 info = &se->ss->data.info;
2918 gfc_init_block (&post);
2919 gfc_init_interface_mapping (&mapping);
2922 formal = sym->formal;
2923 need_interface_mapping = sym->attr.dimension ||
2924 (sym->ts.type == BT_CHARACTER
2925 && sym->ts.u.cl->length
2926 && sym->ts.u.cl->length->expr_type
2931 formal = comp->formal;
2932 need_interface_mapping = comp->attr.dimension ||
2933 (comp->ts.type == BT_CHARACTER
2934 && comp->ts.u.cl->length
2935 && comp->ts.u.cl->length->expr_type
2939 /* Evaluate the arguments. */
2940 for (arg = args; arg != NULL;
2941 arg = arg->next, formal = formal ? formal->next : NULL)
2944 fsym = formal ? formal->sym : NULL;
2945 parm_kind = MISSING;
2949 if (se->ignore_optional)
2951 /* Some intrinsics have already been resolved to the correct
2955 else if (arg->label)
2957 has_alternate_specifier = 1;
2962 /* Pass a NULL pointer for an absent arg. */
2963 gfc_init_se (&parmse, NULL);
2964 parmse.expr = null_pointer_node;
2965 if (arg->missing_arg_type == BT_CHARACTER)
2966 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2969 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2971 /* Pass a NULL pointer to denote an absent arg. */
2972 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2973 gfc_init_se (&parmse, NULL);
2974 parmse.expr = null_pointer_node;
2975 if (arg->missing_arg_type == BT_CHARACTER)
2976 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2978 else if (fsym && fsym->ts.type == BT_CLASS
2979 && e->ts.type == BT_DERIVED)
2981 /* The derived type needs to be converted to a temporary
2983 gfc_init_se (&parmse, se);
2984 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2986 else if (se->ss && se->ss->useflags)
2988 /* An elemental function inside a scalarized loop. */
2989 gfc_init_se (&parmse, se);
2990 gfc_conv_expr_reference (&parmse, e);
2991 parm_kind = ELEMENTAL;
2995 /* A scalar or transformational function. */
2996 gfc_init_se (&parmse, NULL);
2997 argss = gfc_walk_expr (e);
2999 if (argss == gfc_ss_terminator)
3001 if (e->expr_type == EXPR_VARIABLE
3002 && e->symtree->n.sym->attr.cray_pointee
3003 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3005 /* The Cray pointer needs to be converted to a pointer to
3006 a type given by the expression. */
3007 gfc_conv_expr (&parmse, e);
3008 type = build_pointer_type (TREE_TYPE (parmse.expr));
3009 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3010 parmse.expr = convert (type, tmp);
3012 else if (fsym && fsym->attr.value)
3014 if (fsym->ts.type == BT_CHARACTER
3015 && fsym->ts.is_c_interop
3016 && fsym->ns->proc_name != NULL
3017 && fsym->ns->proc_name->attr.is_bind_c)
3020 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3021 if (parmse.expr == NULL)
3022 gfc_conv_expr (&parmse, e);
3025 gfc_conv_expr (&parmse, e);
3027 else if (arg->name && arg->name[0] == '%')
3028 /* Argument list functions %VAL, %LOC and %REF are signalled
3029 through arg->name. */
3030 conv_arglist_function (&parmse, arg->expr, arg->name);
3031 else if ((e->expr_type == EXPR_FUNCTION)
3032 && ((e->value.function.esym
3033 && e->value.function.esym->result->attr.pointer)
3034 || (!e->value.function.esym
3035 && e->symtree->n.sym->attr.pointer))
3036 && fsym && fsym->attr.target)
3038 gfc_conv_expr (&parmse, e);
3039 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3041 else if (e->expr_type == EXPR_FUNCTION
3042 && e->symtree->n.sym->result
3043 && e->symtree->n.sym->result != e->symtree->n.sym
3044 && e->symtree->n.sym->result->attr.proc_pointer)
3046 /* Functions returning procedure pointers. */
3047 gfc_conv_expr (&parmse, e);
3048 if (fsym && fsym->attr.proc_pointer)
3049 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3053 gfc_conv_expr_reference (&parmse, e);
3055 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3056 allocated on entry, it must be deallocated. */
3057 if (fsym && fsym->attr.allocatable
3058 && fsym->attr.intent == INTENT_OUT)
3062 gfc_init_block (&block);
3063 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3065 gfc_add_expr_to_block (&block, tmp);
3066 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3067 void_type_node, parmse.expr,
3069 gfc_add_expr_to_block (&block, tmp);
3071 if (fsym->attr.optional
3072 && e->expr_type == EXPR_VARIABLE
3073 && e->symtree->n.sym->attr.optional)
3075 tmp = fold_build3_loc (input_location, COND_EXPR,
3077 gfc_conv_expr_present (e->symtree->n.sym),
3078 gfc_finish_block (&block),
3079 build_empty_stmt (input_location));
3082 tmp = gfc_finish_block (&block);
3084 gfc_add_expr_to_block (&se->pre, tmp);
3087 if (fsym && e->expr_type != EXPR_NULL
3088 && ((fsym->attr.pointer
3089 && fsym->attr.flavor != FL_PROCEDURE)
3090 || (fsym->attr.proc_pointer
3091 && !(e->expr_type == EXPR_VARIABLE
3092 && e->symtree->n.sym->attr.dummy))
3093 || (fsym->attr.proc_pointer
3094 && e->expr_type == EXPR_VARIABLE
3095 && gfc_is_proc_ptr_comp (e, NULL))
3096 || fsym->attr.allocatable))
3098 /* Scalar pointer dummy args require an extra level of
3099 indirection. The null pointer already contains
3100 this level of indirection. */
3101 parm_kind = SCALAR_POINTER;
3102 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3108 /* If the procedure requires an explicit interface, the actual
3109 argument is passed according to the corresponding formal
3110 argument. If the corresponding formal argument is a POINTER,
3111 ALLOCATABLE or assumed shape, we do not use g77's calling
3112 convention, and pass the address of the array descriptor
3113 instead. Otherwise we use g77's calling convention. */
3116 && !(fsym->attr.pointer || fsym->attr.allocatable)
3117 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3119 f = f || !comp->attr.always_explicit;
3121 f = f || !sym->attr.always_explicit;
3123 /* If the argument is a function call that may not create
3124 a temporary for the result, we have to check that we
3125 can do it, i.e. that there is no alias between this
3126 argument and another one. */
3127 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3133 intent = fsym->attr.intent;
3135 intent = INTENT_UNKNOWN;
3137 if (gfc_check_fncall_dependency (e, intent, sym, args,
3139 parmse.force_tmp = 1;
3141 iarg = e->value.function.actual->expr;
3143 /* Temporary needed if aliasing due to host association. */
3144 if (sym->attr.contained
3146 && !sym->attr.implicit_pure
3147 && !sym->attr.use_assoc
3148 && iarg->expr_type == EXPR_VARIABLE
3149 && sym->ns == iarg->symtree->n.sym->ns)
3150 parmse.force_tmp = 1;
3152 /* Ditto within module. */
3153 if (sym->attr.use_assoc
3155 && !sym->attr.implicit_pure
3156 && iarg->expr_type == EXPR_VARIABLE
3157 && sym->module == iarg->symtree->n.sym->module)
3158 parmse.force_tmp = 1;
3161 if (e->expr_type == EXPR_VARIABLE
3162 && is_subref_array (e))
3163 /* The actual argument is a component reference to an
3164 array of derived types. In this case, the argument
3165 is converted to a temporary, which is passed and then
3166 written back after the procedure call. */
3167 gfc_conv_subref_array_arg (&parmse, e, f,
3168 fsym ? fsym->attr.intent : INTENT_INOUT,
3169 fsym && fsym->attr.pointer);
3171 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3174 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3175 allocated on entry, it must be deallocated. */
3176 if (fsym && fsym->attr.allocatable
3177 && fsym->attr.intent == INTENT_OUT)
3179 tmp = build_fold_indirect_ref_loc (input_location,
3181 tmp = gfc_trans_dealloc_allocated (tmp);
3182 if (fsym->attr.optional
3183 && e->expr_type == EXPR_VARIABLE
3184 && e->symtree->n.sym->attr.optional)
3185 tmp = fold_build3_loc (input_location, COND_EXPR,
3187 gfc_conv_expr_present (e->symtree->n.sym),
3188 tmp, build_empty_stmt (input_location));
3189 gfc_add_expr_to_block (&se->pre, tmp);
3194 /* The case with fsym->attr.optional is that of a user subroutine
3195 with an interface indicating an optional argument. When we call
3196 an intrinsic subroutine, however, fsym is NULL, but we might still
3197 have an optional argument, so we proceed to the substitution
3199 if (e && (fsym == NULL || fsym->attr.optional))
3201 /* If an optional argument is itself an optional dummy argument,
3202 check its presence and substitute a null if absent. This is
3203 only needed when passing an array to an elemental procedure
3204 as then array elements are accessed - or no NULL pointer is
3205 allowed and a "1" or "0" should be passed if not present.
3206 When passing a non-array-descriptor full array to a
3207 non-array-descriptor dummy, no check is needed. For
3208 array-descriptor actual to array-descriptor dummy, see
3209 PR 41911 for why a check has to be inserted.
3210 fsym == NULL is checked as intrinsics required the descriptor
3211 but do not always set fsym. */
3212 if (e->expr_type == EXPR_VARIABLE
3213 && e->symtree->n.sym->attr.optional
3214 && ((e->rank > 0 && sym->attr.elemental)
3215 || e->representation.length || e->ts.type == BT_CHARACTER
3219 && (fsym->as->type == AS_ASSUMED_SHAPE
3220 || fsym->as->type == AS_DEFERRED))))))
3221 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3222 e->representation.length);
3227 /* Obtain the character length of an assumed character length
3228 length procedure from the typespec. */
3229 if (fsym->ts.type == BT_CHARACTER
3230 && parmse.string_length == NULL_TREE
3231 && e->ts.type == BT_PROCEDURE
3232 && e->symtree->n.sym->ts.type == BT_CHARACTER
3233 && e->symtree->n.sym->ts.u.cl->length != NULL
3234 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3236 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3237 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3241 if (fsym && need_interface_mapping && e)
3242 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3244 gfc_add_block_to_block (&se->pre, &parmse.pre);
3245 gfc_add_block_to_block (&post, &parmse.post);
3247 /* Allocated allocatable components of derived types must be
3248 deallocated for non-variable scalars. Non-variable arrays are
3249 dealt with in trans-array.c(gfc_conv_array_parameter). */
3250 if (e && e->ts.type == BT_DERIVED
3251 && e->ts.u.derived->attr.alloc_comp
3252 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3253 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3256 tmp = build_fold_indirect_ref_loc (input_location,
3258 parm_rank = e->rank;
3266 case (SCALAR_POINTER):
3267 tmp = build_fold_indirect_ref_loc (input_location,
3272 if (e->expr_type == EXPR_OP
3273 && e->value.op.op == INTRINSIC_PARENTHESES
3274 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3277 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3278 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3279 gfc_add_expr_to_block (&se->post, local_tmp);
3282 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3284 gfc_add_expr_to_block (&se->post, tmp);
3287 /* Add argument checking of passing an unallocated/NULL actual to
3288 a nonallocatable/nonpointer dummy. */
3290 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3292 symbol_attribute attr;
3296 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3297 attr = gfc_expr_attr (e);
3299 goto end_pointer_check;
3301 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3302 allocatable to an optional dummy, cf. 12.5.2.12. */
3303 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3304 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3305 goto end_pointer_check;
3309 /* If the actual argument is an optional pointer/allocatable and
3310 the formal argument takes an nonpointer optional value,
3311 it is invalid to pass a non-present argument on, even
3312 though there is no technical reason for this in gfortran.
3313 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3314 tree present, null_ptr, type;
3316 if (attr.allocatable
3317 && (fsym == NULL || !fsym->attr.allocatable))
3318 asprintf (&msg, "Allocatable actual argument '%s' is not "
3319 "allocated or not present", e->symtree->n.sym->name);
3320 else if (attr.pointer
3321 && (fsym == NULL || !fsym->attr.pointer))
3322 asprintf (&msg, "Pointer actual argument '%s' is not "
3323 "associated or not present",
3324 e->symtree->n.sym->name);
3325 else if (attr.proc_pointer
3326 && (fsym == NULL || !fsym->attr.proc_pointer))
3327 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3328 "associated or not present",
3329 e->symtree->n.sym->name);
3331 goto end_pointer_check;
3333 present = gfc_conv_expr_present (e->symtree->n.sym);
3334 type = TREE_TYPE (present);
3335 present = fold_build2_loc (input_location, EQ_EXPR,
3336 boolean_type_node, present,
3338 null_pointer_node));
3339 type = TREE_TYPE (parmse.expr);
3340 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3341 boolean_type_node, parmse.expr,
3343 null_pointer_node));
3344 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3345 boolean_type_node, present, null_ptr);
3349 if (attr.allocatable
3350 && (fsym == NULL || !fsym->attr.allocatable))
3351 asprintf (&msg, "Allocatable actual argument '%s' is not "
3352 "allocated", e->symtree->n.sym->name);
3353 else if (attr.pointer
3354 && (fsym == NULL || !fsym->attr.pointer))
3355 asprintf (&msg, "Pointer actual argument '%s' is not "
3356 "associated", e->symtree->n.sym->name);
3357 else if (attr.proc_pointer
3358 && (fsym == NULL || !fsym->attr.proc_pointer))
3359 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3360 "associated", e->symtree->n.sym->name);
3362 goto end_pointer_check;
3366 /* If the argument is passed by value, we need to strip the
3368 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3369 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3371 cond = fold_build2_loc (input_location, EQ_EXPR,
3372 boolean_type_node, tmp,
3373 fold_convert (TREE_TYPE (tmp),
3374 null_pointer_node));
3377 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3383 /* Deferred length dummies pass the character length by reference
3384 so that the value can be returned. */
3385 if (parmse.string_length && fsym && fsym->ts.deferred)
3387 tmp = parmse.string_length;
3388 if (TREE_CODE (tmp) != VAR_DECL)
3389 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3390 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3393 /* Character strings are passed as two parameters, a length and a
3394 pointer - except for Bind(c) which only passes the pointer. */
3395 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3396 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3398 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3399 pass the token and the offset as additional arguments. */
3400 if (fsym && fsym->attr.codimension
3401 && gfc_option.coarray == GFC_FCOARRAY_LIB
3402 && !fsym->attr.allocatable
3405 /* Token and offset. */
3406 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
3407 VEC_safe_push (tree, gc, stringargs,
3408 build_int_cst (gfc_array_index_type, 0));
3409 gcc_assert (fsym->attr.optional);
3411 else if (fsym && fsym->attr.codimension
3412 && !fsym->attr.allocatable
3413 && gfc_option.coarray == GFC_FCOARRAY_LIB)
3415 tree caf_decl, caf_type;
3418 caf_decl = get_tree_for_caf_expr (e);
3419 caf_type = TREE_TYPE (caf_decl);
3421 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3422 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3423 tmp = gfc_conv_descriptor_token (caf_decl);
3424 else if (DECL_LANG_SPECIFIC (caf_decl)
3425 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
3426 tmp = GFC_DECL_TOKEN (caf_decl);
3429 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
3430 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
3431 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
3434 VEC_safe_push (tree, gc, stringargs, tmp);
3436 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3437 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3438 offset = build_int_cst (gfc_array_index_type, 0);
3439 else if (DECL_LANG_SPECIFIC (caf_decl)
3440 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
3441 offset = GFC_DECL_CAF_OFFSET (caf_decl);
3442 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3443 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
3445 offset = build_int_cst (gfc_array_index_type, 0);
3447 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
3448 tmp = gfc_conv_descriptor_data_get (caf_decl);
3451 gcc_assert (POINTER_TYPE_P (caf_type));
3455 if (fsym->as->type == AS_ASSUMED_SHAPE)
3457 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3458 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3459 (TREE_TYPE (parmse.expr))));
3460 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
3461 tmp2 = gfc_conv_descriptor_data_get (tmp2);
3463 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3464 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
3467 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3471 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3472 gfc_array_index_type,
3473 fold_convert (gfc_array_index_type, tmp2),
3474 fold_convert (gfc_array_index_type, tmp));
3475 offset = fold_build2_loc (input_location, PLUS_EXPR,
3476 gfc_array_index_type, offset, tmp);
3478 VEC_safe_push (tree, gc, stringargs, offset);
3481 VEC_safe_push (tree, gc, arglist, parmse.expr);
3483 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3490 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3491 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3492 else if (ts.type == BT_CHARACTER)
3494 if (ts.u.cl->length == NULL)
3496 /* Assumed character length results are not allowed by 5.1.1.5 of the
3497 standard and are trapped in resolve.c; except in the case of SPREAD
3498 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3499 we take the character length of the first argument for the result.
3500 For dummies, we have to look through the formal argument list for
3501 this function and use the character length found there.*/
3502 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3503 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3504 else if (!sym->attr.dummy)
3505 cl.backend_decl = VEC_index (tree, stringargs, 0);
3508 formal = sym->ns->proc_name->formal;
3509 for (; formal; formal = formal->next)
3510 if (strcmp (formal->sym->name, sym->name) == 0)
3511 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3518 /* Calculate the length of the returned string. */
3519 gfc_init_se (&parmse, NULL);
3520 if (need_interface_mapping)
3521 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3523 gfc_conv_expr (&parmse, ts.u.cl->length);
3524 gfc_add_block_to_block (&se->pre, &parmse.pre);
3525 gfc_add_block_to_block (&se->post, &parmse.post);
3527 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3528 tmp = fold_build2_loc (input_location, MAX_EXPR,
3529 gfc_charlen_type_node, tmp,
3530 build_int_cst (gfc_charlen_type_node, 0));
3531 cl.backend_decl = tmp;
3534 /* Set up a charlen structure for it. */
3539 len = cl.backend_decl;
3542 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3543 || (!comp && gfc_return_by_reference (sym));
3546 if (se->direct_byref)
3548 /* Sometimes, too much indirection can be applied; e.g. for
3549 function_result = array_valued_recursive_function. */
3550 if (TREE_TYPE (TREE_TYPE (se->expr))
3551 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3552 && GFC_DESCRIPTOR_TYPE_P
3553 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3554 se->expr = build_fold_indirect_ref_loc (input_location,
3557 /* If the lhs of an assignment x = f(..) is allocatable and
3558 f2003 is allowed, we must do the automatic reallocation.
3559 TODO - deal with intrinsics, without using a temporary. */
3560 if (gfc_option.flag_realloc_lhs
3561 && se->ss && se->ss->loop_chain
3562 && se->ss->loop_chain->is_alloc_lhs
3563 && !expr->value.function.isym
3564 && sym->result->as != NULL)
3566 /* Evaluate the bounds of the result, if known. */
3567 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3570 /* Perform the automatic reallocation. */
3571 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3573 gfc_add_expr_to_block (&se->pre, tmp);
3575 /* Pass the temporary as the first argument. */
3576 result = info->descriptor;
3579 result = build_fold_indirect_ref_loc (input_location,
3581 VEC_safe_push (tree, gc, retargs, se->expr);
3583 else if (comp && comp->attr.dimension)
3585 gcc_assert (se->loop && info);
3587 /* Set the type of the array. */
3588 tmp = gfc_typenode_for_spec (&comp->ts);
3589 gcc_assert (se->ss->dimen == se->loop->dimen);
3591 /* Evaluate the bounds of the result, if known. */
3592 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3594 /* If the lhs of an assignment x = f(..) is allocatable and
3595 f2003 is allowed, we must not generate the function call
3596 here but should just send back the results of the mapping.
3597 This is signalled by the function ss being flagged. */
3598 if (gfc_option.flag_realloc_lhs
3599 && se->ss && se->ss->is_alloc_lhs)
3601 gfc_free_interface_mapping (&mapping);
3602 return has_alternate_specifier;
3605 /* Create a temporary to store the result. In case the function
3606 returns a pointer, the temporary will be a shallow copy and
3607 mustn't be deallocated. */
3608 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3609 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
3610 tmp, NULL_TREE, false,
3611 !comp->attr.pointer, callee_alloc,
3612 &se->ss->info->expr->where);
3614 /* Pass the temporary as the first argument. */
3615 result = info->descriptor;
3616 tmp = gfc_build_addr_expr (NULL_TREE, result);
3617 VEC_safe_push (tree, gc, retargs, tmp);
3619 else if (!comp && sym->result->attr.dimension)
3621 gcc_assert (se->loop && info);
3623 /* Set the type of the array. */
3624 tmp = gfc_typenode_for_spec (&ts);
3625 gcc_assert (se->ss->dimen == se->loop->dimen);
3627 /* Evaluate the bounds of the result, if known. */
3628 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3630 /* If the lhs of an assignment x = f(..) is allocatable and
3631 f2003 is allowed, we must not generate the function call
3632 here but should just send back the results of the mapping.
3633 This is signalled by the function ss being flagged. */
3634 if (gfc_option.flag_realloc_lhs
3635 && se->ss && se->ss->is_alloc_lhs)
3637 gfc_free_interface_mapping (&mapping);
3638 return has_alternate_specifier;
3641 /* Create a temporary to store the result. In case the function
3642 returns a pointer, the temporary will be a shallow copy and
3643 mustn't be deallocated. */
3644 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3645 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
3646 tmp, NULL_TREE, false,
3647 !sym->attr.pointer, callee_alloc,
3648 &se->ss->info->expr->where);
3650 /* Pass the temporary as the first argument. */
3651 result = info->descriptor;
3652 tmp = gfc_build_addr_expr (NULL_TREE, result);
3653 VEC_safe_push (tree, gc, retargs, tmp);
3655 else if (ts.type == BT_CHARACTER)
3657 /* Pass the string length. */
3658 type = gfc_get_character_type (ts.kind, ts.u.cl);
3659 type = build_pointer_type (type);
3661 /* Return an address to a char[0:len-1]* temporary for
3662 character pointers. */
3663 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3664 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3666 var = gfc_create_var (type, "pstr");
3668 if ((!comp && sym->attr.allocatable)
3669 || (comp && comp->attr.allocatable))
3670 gfc_add_modify (&se->pre, var,
3671 fold_convert (TREE_TYPE (var),
3672 null_pointer_node));
3674 /* Provide an address expression for the function arguments. */
3675 var = gfc_build_addr_expr (NULL_TREE, var);
3678 var = gfc_conv_string_tmp (se, type, len);
3680 VEC_safe_push (tree, gc, retargs, var);
3684 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3686 type = gfc_get_complex_type (ts.kind);
3687 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3688 VEC_safe_push (tree, gc, retargs, var);
3691 if (ts.type == BT_CHARACTER && ts.deferred
3692 && (sym->attr.allocatable || sym->attr.pointer))
3695 if (TREE_CODE (tmp) != VAR_DECL)
3696 tmp = gfc_evaluate_now (len, &se->pre);
3697 len = gfc_build_addr_expr (NULL_TREE, tmp);
3700 /* Add the string length to the argument list. */
3701 if (ts.type == BT_CHARACTER)
3702 VEC_safe_push (tree, gc, retargs, len);
3704 gfc_free_interface_mapping (&mapping);
3706 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3707 arglen = (VEC_length (tree, arglist)
3708 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3709 VEC_reserve_exact (tree, gc, retargs, arglen);
3711 /* Add the return arguments. */
3712 VEC_splice (tree, retargs, arglist);
3714 /* Add the hidden string length parameters to the arguments. */
3715 VEC_splice (tree, retargs, stringargs);
3717 /* We may want to append extra arguments here. This is used e.g. for
3718 calls to libgfortran_matmul_??, which need extra information. */
3719 if (!VEC_empty (tree, append_args))
3720 VEC_splice (tree, retargs, append_args);
3723 /* Generate the actual call. */
3724 conv_function_val (se, sym, expr);
3726 /* If there are alternate return labels, function type should be
3727 integer. Can't modify the type in place though, since it can be shared
3728 with other functions. For dummy arguments, the typing is done to
3729 this result, even if it has to be repeated for each call. */
3730 if (has_alternate_specifier
3731 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3733 if (!sym->attr.dummy)
3735 TREE_TYPE (sym->backend_decl)
3736 = build_function_type (integer_type_node,
3737 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3738 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3741 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3744 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3745 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3747 /* If we have a pointer function, but we don't want a pointer, e.g.
3750 where f is pointer valued, we have to dereference the result. */
3751 if (!se->want_pointer && !byref
3752 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3753 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
3754 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3756 /* f2c calling conventions require a scalar default real function to
3757 return a double precision result. Convert this back to default
3758 real. We only care about the cases that can happen in Fortran 77.
3760 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3761 && sym->ts.kind == gfc_default_real_kind
3762 && !sym->attr.always_explicit)
3763 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3765 /* A pure function may still have side-effects - it may modify its
3767 TREE_SIDE_EFFECTS (se->expr) = 1;
3769 if (!sym->attr.pure)
3770 TREE_SIDE_EFFECTS (se->expr) = 1;
3775 /* Add the function call to the pre chain. There is no expression. */
3776 gfc_add_expr_to_block (&se->pre, se->expr);
3777 se->expr = NULL_TREE;
3779 if (!se->direct_byref)
3781 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3783 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3785 /* Check the data pointer hasn't been modified. This would
3786 happen in a function returning a pointer. */
3787 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3788 tmp = fold_build2_loc (input_location, NE_EXPR,
3791 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3794 se->expr = info->descriptor;
3795 /* Bundle in the string length. */
3796 se->string_length = len;
3798 else if (ts.type == BT_CHARACTER)
3800 /* Dereference for character pointer results. */
3801 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3802 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3803 se->expr = build_fold_indirect_ref_loc (input_location, var);
3808 se->string_length = len;
3809 else if (sym->attr.allocatable || sym->attr.pointer)
3810 se->string_length = cl.backend_decl;
3814 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3815 se->expr = build_fold_indirect_ref_loc (input_location, var);
3820 /* Follow the function call with the argument post block. */
3823 gfc_add_block_to_block (&se->pre, &post);
3825 /* Transformational functions of derived types with allocatable
3826 components must have the result allocatable components copied. */
3827 arg = expr->value.function.actual;
3828 if (result && arg && expr->rank
3829 && expr->value.function.isym
3830 && expr->value.function.isym->transformational
3831 && arg->expr->ts.type == BT_DERIVED
3832 && arg->expr->ts.u.derived->attr.alloc_comp)
3835 /* Copy the allocatable components. We have to use a
3836 temporary here to prevent source allocatable components
3837 from being corrupted. */
3838 tmp2 = gfc_evaluate_now (result, &se->pre);
3839 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3840 result, tmp2, expr->rank);
3841 gfc_add_expr_to_block (&se->pre, tmp);
3842 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3844 gfc_add_expr_to_block (&se->pre, tmp);
3846 /* Finally free the temporary's data field. */
3847 tmp = gfc_conv_descriptor_data_get (tmp2);
3848 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3849 gfc_add_expr_to_block (&se->pre, tmp);
3853 gfc_add_block_to_block (&se->post, &post);
3855 return has_alternate_specifier;
3859 /* Fill a character string with spaces. */
3862 fill_with_spaces (tree start, tree type, tree size)
3864 stmtblock_t block, loop;
3865 tree i, el, exit_label, cond, tmp;
3867 /* For a simple char type, we can call memset(). */
3868 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3869 return build_call_expr_loc (input_location,
3870 builtin_decl_explicit (BUILT_IN_MEMSET),
3872 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3873 lang_hooks.to_target_charset (' ')),
3876 /* Otherwise, we use a loop:
3877 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3881 /* Initialize variables. */
3882 gfc_init_block (&block);
3883 i = gfc_create_var (sizetype, "i");
3884 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3885 el = gfc_create_var (build_pointer_type (type), "el");
3886 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3887 exit_label = gfc_build_label_decl (NULL_TREE);
3888 TREE_USED (exit_label) = 1;
3892 gfc_init_block (&loop);
3894 /* Exit condition. */
3895 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3896 build_zero_cst (sizetype));
3897 tmp = build1_v (GOTO_EXPR, exit_label);
3898 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3899 build_empty_stmt (input_location));
3900 gfc_add_expr_to_block (&loop, tmp);
3903 gfc_add_modify (&loop,
3904 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3905 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3907 /* Increment loop variables. */
3908 gfc_add_modify (&loop, i,
3909 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3910 TYPE_SIZE_UNIT (type)));
3911 gfc_add_modify (&loop, el,
3912 fold_build_pointer_plus_loc (input_location,
3913 el, TYPE_SIZE_UNIT (type)));
3915 /* Making the loop... actually loop! */
3916 tmp = gfc_finish_block (&loop);
3917 tmp = build1_v (LOOP_EXPR, tmp);
3918 gfc_add_expr_to_block (&block, tmp);
3920 /* The exit label. */
3921 tmp = build1_v (LABEL_EXPR, exit_label);
3922 gfc_add_expr_to_block (&block, tmp);
3925 return gfc_finish_block (&block);
3929 /* Generate code to copy a string. */
3932 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3933 int dkind, tree slength, tree src, int skind)
3935 tree tmp, dlen, slen;
3944 stmtblock_t tempblock;
3946 gcc_assert (dkind == skind);
3948 if (slength != NULL_TREE)
3950 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3951 ssc = gfc_string_to_single_character (slen, src, skind);
3955 slen = build_int_cst (size_type_node, 1);
3959 if (dlength != NULL_TREE)
3961 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3962 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3966 dlen = build_int_cst (size_type_node, 1);
3970 /* Assign directly if the types are compatible. */
3971 if (dsc != NULL_TREE && ssc != NULL_TREE
3972 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3974 gfc_add_modify (block, dsc, ssc);
3978 /* Do nothing if the destination length is zero. */
3979 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3980 build_int_cst (size_type_node, 0));
3982 /* The following code was previously in _gfortran_copy_string:
3984 // The two strings may overlap so we use memmove.
3986 copy_string (GFC_INTEGER_4 destlen, char * dest,
3987 GFC_INTEGER_4 srclen, const char * src)
3989 if (srclen >= destlen)
3991 // This will truncate if too long.
3992 memmove (dest, src, destlen);
3996 memmove (dest, src, srclen);
3998 memset (&dest[srclen], ' ', destlen - srclen);
4002 We're now doing it here for better optimization, but the logic
4005 /* For non-default character kinds, we have to multiply the string
4006 length by the base type size. */
4007 chartype = gfc_get_char_type (dkind);
4008 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4009 fold_convert (size_type_node, slen),
4010 fold_convert (size_type_node,
4011 TYPE_SIZE_UNIT (chartype)));
4012 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4013 fold_convert (size_type_node, dlen),
4014 fold_convert (size_type_node,
4015 TYPE_SIZE_UNIT (chartype)));
4017 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4018 dest = fold_convert (pvoid_type_node, dest);
4020 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4022 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4023 src = fold_convert (pvoid_type_node, src);
4025 src = gfc_build_addr_expr (pvoid_type_node, src);
4027 /* Truncate string if source is too long. */
4028 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4030 tmp2 = build_call_expr_loc (input_location,
4031 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4032 3, dest, src, dlen);
4034 /* Else copy and pad with spaces. */
4035 tmp3 = build_call_expr_loc (input_location,
4036 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4037 3, dest, src, slen);
4039 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4040 tmp4 = fill_with_spaces (tmp4, chartype,
4041 fold_build2_loc (input_location, MINUS_EXPR,
4042 TREE_TYPE(dlen), dlen, slen));
4044 gfc_init_block (&tempblock);
4045 gfc_add_expr_to_block (&tempblock, tmp3);
4046 gfc_add_expr_to_block (&tempblock, tmp4);
4047 tmp3 = gfc_finish_block (&tempblock);
4049 /* The whole copy_string function is there. */
4050 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4052 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4053 build_empty_stmt (input_location));
4054 gfc_add_expr_to_block (block, tmp);
4058 /* Translate a statement function.
4059 The value of a statement function reference is obtained by evaluating the
4060 expression using the values of the actual arguments for the values of the
4061 corresponding dummy arguments. */
4064 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4068 gfc_formal_arglist *fargs;
4069 gfc_actual_arglist *args;
4072 gfc_saved_var *saved_vars;
4078 sym = expr->symtree->n.sym;
4079 args = expr->value.function.actual;
4080 gfc_init_se (&lse, NULL);
4081 gfc_init_se (&rse, NULL);
4084 for (fargs = sym->formal; fargs; fargs = fargs->next)
4086 saved_vars = XCNEWVEC (gfc_saved_var, n);
4087 temp_vars = XCNEWVEC (tree, n);
4089 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4091 /* Each dummy shall be specified, explicitly or implicitly, to be
4093 gcc_assert (fargs->sym->attr.dimension == 0);
4096 if (fsym->ts.type == BT_CHARACTER)
4098 /* Copy string arguments. */
4101 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4102 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4104 /* Create a temporary to hold the value. */
4105 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4106 fsym->ts.u.cl->backend_decl
4107 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4109 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4110 temp_vars[n] = gfc_create_var (type, fsym->name);
4112 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4114 gfc_conv_expr (&rse, args->expr);
4115 gfc_conv_string_parameter (&rse);
4116 gfc_add_block_to_block (&se->pre, &lse.pre);
4117 gfc_add_block_to_block (&se->pre, &rse.pre);
4119 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4120 rse.string_length, rse.expr, fsym->ts.kind);
4121 gfc_add_block_to_block (&se->pre, &lse.post);
4122 gfc_add_block_to_block (&se->pre, &rse.post);
4126 /* For everything else, just evaluate the expression. */
4128 /* Create a temporary to hold the value. */
4129 type = gfc_typenode_for_spec (&fsym->ts);
4130 temp_vars[n] = gfc_create_var (type, fsym->name);
4132 gfc_conv_expr (&lse, args->expr);
4134 gfc_add_block_to_block (&se->pre, &lse.pre);
4135 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4136 gfc_add_block_to_block (&se->pre, &lse.post);
4142 /* Use the temporary variables in place of the real ones. */
4143 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4144 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4146 gfc_conv_expr (se, sym->value);
4148 if (sym->ts.type == BT_CHARACTER)
4150 gfc_conv_const_charlen (sym->ts.u.cl);
4152 /* Force the expression to the correct length. */
4153 if (!INTEGER_CST_P (se->string_length)
4154 || tree_int_cst_lt (se->string_length,
4155 sym->ts.u.cl->backend_decl))
4157 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4158 tmp = gfc_create_var (type, sym->name);
4159 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4160 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4161 sym->ts.kind, se->string_length, se->expr,
4165 se->string_length = sym->ts.u.cl->backend_decl;
4168 /* Restore the original variables. */
4169 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4170 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4175 /* Translate a function expression. */
4178 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4182 if (expr->value.function.isym)
4184 gfc_conv_intrinsic_function (se, expr);
4188 /* We distinguish statement functions from general functions to improve
4189 runtime performance. */
4190 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4192 gfc_conv_statement_function (se, expr);
4196 /* expr.value.function.esym is the resolved (specific) function symbol for
4197 most functions. However this isn't set for dummy procedures. */
4198 sym = expr->value.function.esym;
4200 sym = expr->symtree->n.sym;
4202 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4206 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4209 is_zero_initializer_p (gfc_expr * expr)
4211 if (expr->expr_type != EXPR_CONSTANT)
4214 /* We ignore constants with prescribed memory representations for now. */
4215 if (expr->representation.string)
4218 switch (expr->ts.type)
4221 return mpz_cmp_si (expr->value.integer, 0) == 0;
4224 return mpfr_zero_p (expr->value.real)
4225 && MPFR_SIGN (expr->value.real) >= 0;
4228 return expr->value.logical == 0;
4231 return mpfr_zero_p (mpc_realref (expr->value.complex))
4232 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4233 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4234 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4244 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4249 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
4250 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
4252 gfc_conv_tmp_array_ref (se);
4256 /* Build a static initializer. EXPR is the expression for the initial value.
4257 The other parameters describe the variable of the component being
4258 initialized. EXPR may be null. */
4261 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4262 bool array, bool pointer, bool procptr)
4266 if (!(expr || pointer || procptr))
4269 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4270 (these are the only two iso_c_binding derived types that can be
4271 used as initialization expressions). If so, we need to modify
4272 the 'expr' to be that for a (void *). */
4273 if (expr != NULL && expr->ts.type == BT_DERIVED
4274 && expr->ts.is_iso_c && expr->ts.u.derived)
4276 gfc_symbol *derived = expr->ts.u.derived;
4278 /* The derived symbol has already been converted to a (void *). Use
4280 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4281 expr->ts.f90_type = derived->ts.f90_type;
4283 gfc_init_se (&se, NULL);
4284 gfc_conv_constant (&se, expr);
4285 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4289 if (array && !procptr)
4292 /* Arrays need special handling. */
4294 ctor = gfc_build_null_descriptor (type);
4295 /* Special case assigning an array to zero. */
4296 else if (is_zero_initializer_p (expr))
4297 ctor = build_constructor (type, NULL);
4299 ctor = gfc_conv_array_initializer (type, expr);
4300 TREE_STATIC (ctor) = 1;
4303 else if (pointer || procptr)
4305 if (!expr || expr->expr_type == EXPR_NULL)
4306 return fold_convert (type, null_pointer_node);
4309 gfc_init_se (&se, NULL);
4310 se.want_pointer = 1;
4311 gfc_conv_expr (&se, expr);
4312 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4322 gfc_init_se (&se, NULL);
4323 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4324 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4326 gfc_conv_structure (&se, expr, 1);
4327 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4328 TREE_STATIC (se.expr) = 1;
4333 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4334 TREE_STATIC (ctor) = 1;
4339 gfc_init_se (&se, NULL);
4340 gfc_conv_constant (&se, expr);
4341 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4348 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4354 gfc_array_info *lss_array;
4361 gfc_start_block (&block);
4363 /* Initialize the scalarizer. */
4364 gfc_init_loopinfo (&loop);
4366 gfc_init_se (&lse, NULL);
4367 gfc_init_se (&rse, NULL);
4370 rss = gfc_walk_expr (expr);
4371 if (rss == gfc_ss_terminator)
4372 /* The rhs is scalar. Add a ss for the expression. */
4373 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4375 /* Create a SS for the destination. */
4376 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4378 lss_array = &lss->data.info;
4379 lss_array->shape = gfc_get_shape (cm->as->rank);
4380 lss_array->descriptor = dest;
4381 lss_array->data = gfc_conv_array_data (dest);
4382 lss_array->offset = gfc_conv_array_offset (dest);
4383 for (n = 0; n < cm->as->rank; n++)
4385 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
4386 lss_array->stride[n] = gfc_index_one_node;
4388 mpz_init (lss_array->shape[n]);
4389 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
4390 cm->as->lower[n]->value.integer);
4391 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
4394 /* Associate the SS with the loop. */
4395 gfc_add_ss_to_loop (&loop, lss);
4396 gfc_add_ss_to_loop (&loop, rss);
4398 /* Calculate the bounds of the scalarization. */
4399 gfc_conv_ss_startstride (&loop);
4401 /* Setup the scalarizing loops. */
4402 gfc_conv_loop_setup (&loop, &expr->where);
4404 /* Setup the gfc_se structures. */
4405 gfc_copy_loopinfo_to_se (&lse, &loop);
4406 gfc_copy_loopinfo_to_se (&rse, &loop);
4409 gfc_mark_ss_chain_used (rss, 1);
4411 gfc_mark_ss_chain_used (lss, 1);
4413 /* Start the scalarized loop body. */
4414 gfc_start_scalarized_body (&loop, &body);
4416 gfc_conv_tmp_array_ref (&lse);
4417 if (cm->ts.type == BT_CHARACTER)
4418 lse.string_length = cm->ts.u.cl->backend_decl;
4420 gfc_conv_expr (&rse, expr);
4422 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4423 gfc_add_expr_to_block (&body, tmp);
4425 gcc_assert (rse.ss == gfc_ss_terminator);
4427 /* Generate the copying loops. */
4428 gfc_trans_scalarizing_loops (&loop, &body);
4430 /* Wrap the whole thing up. */
4431 gfc_add_block_to_block (&block, &loop.pre);
4432 gfc_add_block_to_block (&block, &loop.post);
4434 gcc_assert (lss_array->shape != NULL);
4435 gfc_free_shape (&lss_array->shape, cm->as->rank);
4436 gfc_cleanup_loop (&loop);
4438 return gfc_finish_block (&block);
4443 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4454 gfc_expr *arg = NULL;
4456 gfc_start_block (&block);
4457 gfc_init_se (&se, NULL);
4459 /* Get the descriptor for the expressions. */
4460 rss = gfc_walk_expr (expr);
4461 se.want_pointer = 0;
4462 gfc_conv_expr_descriptor (&se, expr, rss);
4463 gfc_add_block_to_block (&block, &se.pre);
4464 gfc_add_modify (&block, dest, se.expr);
4466 /* Deal with arrays of derived types with allocatable components. */
4467 if (cm->ts.type == BT_DERIVED
4468 && cm->ts.u.derived->attr.alloc_comp)
4469 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4473 tmp = gfc_duplicate_allocatable (dest, se.expr,
4474 TREE_TYPE(cm->backend_decl),
4477 gfc_add_expr_to_block (&block, tmp);
4478 gfc_add_block_to_block (&block, &se.post);
4480 if (expr->expr_type != EXPR_VARIABLE)
4481 gfc_conv_descriptor_data_set (&block, se.expr,
4484 /* We need to know if the argument of a conversion function is a
4485 variable, so that the correct lower bound can be used. */
4486 if (expr->expr_type == EXPR_FUNCTION
4487 && expr->value.function.isym
4488 && expr->value.function.isym->conversion
4489 && expr->value.function.actual->expr
4490 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4491 arg = expr->value.function.actual->expr;
4493 /* Obtain the array spec of full array references. */
4495 as = gfc_get_full_arrayspec_from_expr (arg);
4497 as = gfc_get_full_arrayspec_from_expr (expr);
4499 /* Shift the lbound and ubound of temporaries to being unity,
4500 rather than zero, based. Always calculate the offset. */
4501 offset = gfc_conv_descriptor_offset_get (dest);
4502 gfc_add_modify (&block, offset, gfc_index_zero_node);
4503 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4505 for (n = 0; n < expr->rank; n++)
4510 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4511 TODO It looks as if gfc_conv_expr_descriptor should return
4512 the correct bounds and that the following should not be
4513 necessary. This would simplify gfc_conv_intrinsic_bound
4515 if (as && as->lower[n])
4518 gfc_init_se (&lbse, NULL);
4519 gfc_conv_expr (&lbse, as->lower[n]);
4520 gfc_add_block_to_block (&block, &lbse.pre);
4521 lbound = gfc_evaluate_now (lbse.expr, &block);
4525 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4526 lbound = gfc_conv_descriptor_lbound_get (tmp,
4530 lbound = gfc_conv_descriptor_lbound_get (dest,
4533 lbound = gfc_index_one_node;
4535 lbound = fold_convert (gfc_array_index_type, lbound);
4537 /* Shift the bounds and set the offset accordingly. */
4538 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4539 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4540 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4541 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4543 gfc_conv_descriptor_ubound_set (&block, dest,
4544 gfc_rank_cst[n], tmp);
4545 gfc_conv_descriptor_lbound_set (&block, dest,
4546 gfc_rank_cst[n], lbound);
4548 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4549 gfc_conv_descriptor_lbound_get (dest,
4551 gfc_conv_descriptor_stride_get (dest,
4553 gfc_add_modify (&block, tmp2, tmp);
4554 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4556 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4561 /* If a conversion expression has a null data pointer
4562 argument, nullify the allocatable component. */
4566 if (arg->symtree->n.sym->attr.allocatable
4567 || arg->symtree->n.sym->attr.pointer)
4569 non_null_expr = gfc_finish_block (&block);
4570 gfc_start_block (&block);
4571 gfc_conv_descriptor_data_set (&block, dest,
4573 null_expr = gfc_finish_block (&block);
4574 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4575 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4576 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4577 return build3_v (COND_EXPR, tmp,
4578 null_expr, non_null_expr);
4582 return gfc_finish_block (&block);
4586 /* Assign a single component of a derived type constructor. */
4589 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4597 gfc_start_block (&block);
4599 if (cm->attr.pointer)
4601 gfc_init_se (&se, NULL);
4602 /* Pointer component. */
4603 if (cm->attr.dimension)
4605 /* Array pointer. */
4606 if (expr->expr_type == EXPR_NULL)
4607 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4610 rss = gfc_walk_expr (expr);
4611 se.direct_byref = 1;
4613 gfc_conv_expr_descriptor (&se, expr, rss);
4614 gfc_add_block_to_block (&block, &se.pre);
4615 gfc_add_block_to_block (&block, &se.post);
4620 /* Scalar pointers. */
4621 se.want_pointer = 1;
4622 gfc_conv_expr (&se, expr);
4623 gfc_add_block_to_block (&block, &se.pre);
4624 gfc_add_modify (&block, dest,
4625 fold_convert (TREE_TYPE (dest), se.expr));
4626 gfc_add_block_to_block (&block, &se.post);
4629 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4631 /* NULL initialization for CLASS components. */
4632 tmp = gfc_trans_structure_assign (dest,
4633 gfc_class_null_initializer (&cm->ts));
4634 gfc_add_expr_to_block (&block, tmp);
4636 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4638 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4639 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4640 else if (cm->attr.allocatable)
4642 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4643 gfc_add_expr_to_block (&block, tmp);
4647 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4648 gfc_add_expr_to_block (&block, tmp);
4651 else if (expr->ts.type == BT_DERIVED)
4653 if (expr->expr_type != EXPR_STRUCTURE)
4655 gfc_init_se (&se, NULL);
4656 gfc_conv_expr (&se, expr);
4657 gfc_add_block_to_block (&block, &se.pre);
4658 gfc_add_modify (&block, dest,
4659 fold_convert (TREE_TYPE (dest), se.expr));
4660 gfc_add_block_to_block (&block, &se.post);
4664 /* Nested constructors. */
4665 tmp = gfc_trans_structure_assign (dest, expr);
4666 gfc_add_expr_to_block (&block, tmp);
4671 /* Scalar component. */
4672 gfc_init_se (&se, NULL);
4673 gfc_init_se (&lse, NULL);
4675 gfc_conv_expr (&se, expr);
4676 if (cm->ts.type == BT_CHARACTER)
4677 lse.string_length = cm->ts.u.cl->backend_decl;
4679 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4680 gfc_add_expr_to_block (&block, tmp);
4682 return gfc_finish_block (&block);
4685 /* Assign a derived type constructor to a variable. */
4688 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4696 gfc_start_block (&block);
4697 cm = expr->ts.u.derived->components;
4699 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4700 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4701 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4705 gcc_assert (cm->backend_decl == NULL);
4706 gfc_init_se (&se, NULL);
4707 gfc_init_se (&lse, NULL);
4708 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4710 gfc_add_modify (&block, lse.expr,
4711 fold_convert (TREE_TYPE (lse.expr), se.expr));
4713 return gfc_finish_block (&block);
4716 for (c = gfc_constructor_first (expr->value.constructor);
4717 c; c = gfc_constructor_next (c), cm = cm->next)
4719 /* Skip absent members in default initializers. */
4723 field = cm->backend_decl;
4724 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4725 dest, field, NULL_TREE);
4726 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4727 gfc_add_expr_to_block (&block, tmp);
4729 return gfc_finish_block (&block);
4732 /* Build an expression for a constructor. If init is nonzero then
4733 this is part of a static variable initializer. */
4736 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4743 VEC(constructor_elt,gc) *v = NULL;
4745 gcc_assert (se->ss == NULL);
4746 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4747 type = gfc_typenode_for_spec (&expr->ts);
4751 /* Create a temporary variable and fill it in. */
4752 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4753 tmp = gfc_trans_structure_assign (se->expr, expr);
4754 gfc_add_expr_to_block (&se->pre, tmp);
4758 cm = expr->ts.u.derived->components;
4760 for (c = gfc_constructor_first (expr->value.constructor);
4761 c; c = gfc_constructor_next (c), cm = cm->next)
4763 /* Skip absent members in default initializers and allocatable
4764 components. Although the latter have a default initializer
4765 of EXPR_NULL,... by default, the static nullify is not needed
4766 since this is done every time we come into scope. */
4767 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
4770 if (strcmp (cm->name, "_size") == 0)
4772 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4773 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4775 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4776 && strcmp (cm->name, "_extends") == 0)
4780 vtabs = cm->initializer->symtree->n.sym;
4781 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4782 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4786 val = gfc_conv_initializer (c->expr, &cm->ts,
4787 TREE_TYPE (cm->backend_decl),
4788 cm->attr.dimension, cm->attr.pointer,
4789 cm->attr.proc_pointer);
4791 /* Append it to the constructor list. */
4792 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4795 se->expr = build_constructor (type, v);
4797 TREE_CONSTANT (se->expr) = 1;
4801 /* Translate a substring expression. */
4804 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4810 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4812 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4813 expr->value.character.length,
4814 expr->value.character.string);
4816 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4817 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4820 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4824 /* Entry point for expression translation. Evaluates a scalar quantity.
4825 EXPR is the expression to be translated, and SE is the state structure if
4826 called from within the scalarized. */
4829 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4834 if (ss && ss->info->expr == expr
4835 && (ss->info->type == GFC_SS_SCALAR
4836 || ss->info->type == GFC_SS_REFERENCE))
4838 gfc_ss_info *ss_info;
4841 /* Substitute a scalar expression evaluated outside the scalarization
4843 se->expr = se->ss->data.scalar.expr;
4844 if (ss_info->type == GFC_SS_REFERENCE)
4845 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4846 se->string_length = ss_info->string_length;
4847 gfc_advance_se_ss_chain (se);
4851 /* We need to convert the expressions for the iso_c_binding derived types.
4852 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4853 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4854 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4855 updated to be an integer with a kind equal to the size of a (void *). */
4856 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4857 && expr->ts.u.derived->attr.is_iso_c)
4859 if (expr->expr_type == EXPR_VARIABLE
4860 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4861 || expr->symtree->n.sym->intmod_sym_id
4862 == ISOCBINDING_NULL_FUNPTR))
4864 /* Set expr_type to EXPR_NULL, which will result in
4865 null_pointer_node being used below. */
4866 expr->expr_type = EXPR_NULL;
4870 /* Update the type/kind of the expression to be what the new
4871 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4872 expr->ts.type = expr->ts.u.derived->ts.type;
4873 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4874 expr->ts.kind = expr->ts.u.derived->ts.kind;
4878 switch (expr->expr_type)
4881 gfc_conv_expr_op (se, expr);
4885 gfc_conv_function_expr (se, expr);
4889 gfc_conv_constant (se, expr);
4893 gfc_conv_variable (se, expr);
4897 se->expr = null_pointer_node;
4900 case EXPR_SUBSTRING:
4901 gfc_conv_substring_expr (se, expr);
4904 case EXPR_STRUCTURE:
4905 gfc_conv_structure (se, expr, 0);
4909 gfc_conv_array_constructor_expr (se, expr);
4918 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4919 of an assignment. */
4921 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4923 gfc_conv_expr (se, expr);
4924 /* All numeric lvalues should have empty post chains. If not we need to
4925 figure out a way of rewriting an lvalue so that it has no post chain. */
4926 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4929 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4930 numeric expressions. Used for scalar values where inserting cleanup code
4933 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4937 gcc_assert (expr->ts.type != BT_CHARACTER);
4938 gfc_conv_expr (se, expr);
4941 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4942 gfc_add_modify (&se->pre, val, se->expr);
4944 gfc_add_block_to_block (&se->pre, &se->post);
4948 /* Helper to translate an expression and convert it to a particular type. */
4950 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4952 gfc_conv_expr_val (se, expr);
4953 se->expr = convert (type, se->expr);
4957 /* Converts an expression so that it can be passed by reference. Scalar
4961 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4967 if (ss && ss->info->expr == expr
4968 && ss->info->type == GFC_SS_REFERENCE)
4970 /* Returns a reference to the scalar evaluated outside the loop
4972 gfc_conv_expr (se, expr);
4976 if (expr->ts.type == BT_CHARACTER)
4978 gfc_conv_expr (se, expr);
4979 gfc_conv_string_parameter (se);
4983 if (expr->expr_type == EXPR_VARIABLE)
4985 se->want_pointer = 1;
4986 gfc_conv_expr (se, expr);
4989 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4990 gfc_add_modify (&se->pre, var, se->expr);
4991 gfc_add_block_to_block (&se->pre, &se->post);
4997 if (expr->expr_type == EXPR_FUNCTION
4998 && ((expr->value.function.esym
4999 && expr->value.function.esym->result->attr.pointer
5000 && !expr->value.function.esym->result->attr.dimension)
5001 || (!expr->value.function.esym
5002 && expr->symtree->n.sym->attr.pointer
5003 && !expr->symtree->n.sym->attr.dimension)))
5005 se->want_pointer = 1;
5006 gfc_conv_expr (se, expr);
5007 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5008 gfc_add_modify (&se->pre, var, se->expr);
5014 gfc_conv_expr (se, expr);
5016 /* Create a temporary var to hold the value. */
5017 if (TREE_CONSTANT (se->expr))
5019 tree tmp = se->expr;
5020 STRIP_TYPE_NOPS (tmp);
5021 var = build_decl (input_location,
5022 CONST_DECL, NULL, TREE_TYPE (tmp));
5023 DECL_INITIAL (var) = tmp;
5024 TREE_STATIC (var) = 1;
5029 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5030 gfc_add_modify (&se->pre, var, se->expr);
5032 gfc_add_block_to_block (&se->pre, &se->post);
5034 /* Take the address of that value. */
5035 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5040 gfc_trans_pointer_assign (gfc_code * code)
5042 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5046 /* Generate code for a pointer assignment. */
5049 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5060 gfc_start_block (&block);
5062 gfc_init_se (&lse, NULL);
5064 lss = gfc_walk_expr (expr1);
5065 rss = gfc_walk_expr (expr2);
5066 if (lss == gfc_ss_terminator)
5068 /* Scalar pointers. */
5069 lse.want_pointer = 1;
5070 gfc_conv_expr (&lse, expr1);
5071 gcc_assert (rss == gfc_ss_terminator);
5072 gfc_init_se (&rse, NULL);
5073 rse.want_pointer = 1;
5074 gfc_conv_expr (&rse, expr2);
5076 if (expr1->symtree->n.sym->attr.proc_pointer
5077 && expr1->symtree->n.sym->attr.dummy)
5078 lse.expr = build_fold_indirect_ref_loc (input_location,
5081 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5082 && expr2->symtree->n.sym->attr.dummy)
5083 rse.expr = build_fold_indirect_ref_loc (input_location,
5086 gfc_add_block_to_block (&block, &lse.pre);
5087 gfc_add_block_to_block (&block, &rse.pre);
5089 /* Check character lengths if character expression. The test is only
5090 really added if -fbounds-check is enabled. Exclude deferred
5091 character length lefthand sides. */
5092 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5093 && !(expr1->ts.deferred
5094 && (TREE_CODE (lse.string_length) == VAR_DECL))
5095 && !expr1->symtree->n.sym->attr.proc_pointer
5096 && !gfc_is_proc_ptr_comp (expr1, NULL))
5098 gcc_assert (expr2->ts.type == BT_CHARACTER);
5099 gcc_assert (lse.string_length && rse.string_length);
5100 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5101 lse.string_length, rse.string_length,
5105 /* The assignment to an deferred character length sets the string
5106 length to that of the rhs. */
5107 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5109 if (expr2->expr_type != EXPR_NULL)
5110 gfc_add_modify (&block, lse.string_length, rse.string_length);
5112 gfc_add_modify (&block, lse.string_length,
5113 build_int_cst (gfc_charlen_type_node, 0));
5116 gfc_add_modify (&block, lse.expr,
5117 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5119 gfc_add_block_to_block (&block, &rse.post);
5120 gfc_add_block_to_block (&block, &lse.post);
5127 tree strlen_rhs = NULL_TREE;
5129 /* Array pointer. Find the last reference on the LHS and if it is an
5130 array section ref, we're dealing with bounds remapping. In this case,
5131 set it to AR_FULL so that gfc_conv_expr_descriptor does
5132 not see it and process the bounds remapping afterwards explicitely. */
5133 for (remap = expr1->ref; remap; remap = remap->next)
5134 if (!remap->next && remap->type == REF_ARRAY
5135 && remap->u.ar.type == AR_SECTION)
5137 remap->u.ar.type = AR_FULL;
5140 rank_remap = (remap && remap->u.ar.end[0]);
5142 gfc_conv_expr_descriptor (&lse, expr1, lss);
5143 strlen_lhs = lse.string_length;
5146 if (expr2->expr_type == EXPR_NULL)
5148 /* Just set the data pointer to null. */
5149 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5151 else if (rank_remap)
5153 /* If we are rank-remapping, just get the RHS's descriptor and
5154 process this later on. */
5155 gfc_init_se (&rse, NULL);
5156 rse.direct_byref = 1;
5157 rse.byref_noassign = 1;
5158 gfc_conv_expr_descriptor (&rse, expr2, rss);
5159 strlen_rhs = rse.string_length;
5161 else if (expr2->expr_type == EXPR_VARIABLE)
5163 /* Assign directly to the LHS's descriptor. */
5164 lse.direct_byref = 1;
5165 gfc_conv_expr_descriptor (&lse, expr2, rss);
5166 strlen_rhs = lse.string_length;
5168 /* If this is a subreference array pointer assignment, use the rhs
5169 descriptor element size for the lhs span. */
5170 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5172 decl = expr1->symtree->n.sym->backend_decl;
5173 gfc_init_se (&rse, NULL);
5174 rse.descriptor_only = 1;
5175 gfc_conv_expr (&rse, expr2);
5176 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5177 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5178 if (!INTEGER_CST_P (tmp))
5179 gfc_add_block_to_block (&lse.post, &rse.pre);
5180 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5185 /* Assign to a temporary descriptor and then copy that
5186 temporary to the pointer. */
5187 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5190 lse.direct_byref = 1;
5191 gfc_conv_expr_descriptor (&lse, expr2, rss);
5192 strlen_rhs = lse.string_length;
5193 gfc_add_modify (&lse.pre, desc, tmp);
5196 gfc_add_block_to_block (&block, &lse.pre);
5198 gfc_add_block_to_block (&block, &rse.pre);
5200 /* If we do bounds remapping, update LHS descriptor accordingly. */
5204 gcc_assert (remap->u.ar.dimen == expr1->rank);
5208 /* Do rank remapping. We already have the RHS's descriptor
5209 converted in rse and now have to build the correct LHS
5210 descriptor for it. */
5214 tree lbound, ubound;
5217 dtype = gfc_conv_descriptor_dtype (desc);
5218 tmp = gfc_get_dtype (TREE_TYPE (desc));
5219 gfc_add_modify (&block, dtype, tmp);
5221 /* Copy data pointer. */
5222 data = gfc_conv_descriptor_data_get (rse.expr);
5223 gfc_conv_descriptor_data_set (&block, desc, data);
5225 /* Copy offset but adjust it such that it would correspond
5226 to a lbound of zero. */
5227 offs = gfc_conv_descriptor_offset_get (rse.expr);
5228 for (dim = 0; dim < expr2->rank; ++dim)
5230 stride = gfc_conv_descriptor_stride_get (rse.expr,
5232 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5234 tmp = fold_build2_loc (input_location, MULT_EXPR,
5235 gfc_array_index_type, stride, lbound);
5236 offs = fold_build2_loc (input_location, PLUS_EXPR,
5237 gfc_array_index_type, offs, tmp);
5239 gfc_conv_descriptor_offset_set (&block, desc, offs);
5241 /* Set the bounds as declared for the LHS and calculate strides as
5242 well as another offset update accordingly. */
5243 stride = gfc_conv_descriptor_stride_get (rse.expr,
5245 for (dim = 0; dim < expr1->rank; ++dim)
5250 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5252 /* Convert declared bounds. */
5253 gfc_init_se (&lower_se, NULL);
5254 gfc_init_se (&upper_se, NULL);
5255 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5256 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5258 gfc_add_block_to_block (&block, &lower_se.pre);
5259 gfc_add_block_to_block (&block, &upper_se.pre);
5261 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5262 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5264 lbound = gfc_evaluate_now (lbound, &block);
5265 ubound = gfc_evaluate_now (ubound, &block);
5267 gfc_add_block_to_block (&block, &lower_se.post);
5268 gfc_add_block_to_block (&block, &upper_se.post);
5270 /* Set bounds in descriptor. */
5271 gfc_conv_descriptor_lbound_set (&block, desc,
5272 gfc_rank_cst[dim], lbound);
5273 gfc_conv_descriptor_ubound_set (&block, desc,
5274 gfc_rank_cst[dim], ubound);
5277 stride = gfc_evaluate_now (stride, &block);
5278 gfc_conv_descriptor_stride_set (&block, desc,
5279 gfc_rank_cst[dim], stride);
5281 /* Update offset. */
5282 offs = gfc_conv_descriptor_offset_get (desc);
5283 tmp = fold_build2_loc (input_location, MULT_EXPR,
5284 gfc_array_index_type, lbound, stride);
5285 offs = fold_build2_loc (input_location, MINUS_EXPR,
5286 gfc_array_index_type, offs, tmp);
5287 offs = gfc_evaluate_now (offs, &block);
5288 gfc_conv_descriptor_offset_set (&block, desc, offs);
5290 /* Update stride. */
5291 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5292 stride = fold_build2_loc (input_location, MULT_EXPR,
5293 gfc_array_index_type, stride, tmp);
5298 /* Bounds remapping. Just shift the lower bounds. */
5300 gcc_assert (expr1->rank == expr2->rank);
5302 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5306 gcc_assert (remap->u.ar.start[dim]);
5307 gcc_assert (!remap->u.ar.end[dim]);
5308 gfc_init_se (&lbound_se, NULL);
5309 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5311 gfc_add_block_to_block (&block, &lbound_se.pre);
5312 gfc_conv_shift_descriptor_lbound (&block, desc,
5313 dim, lbound_se.expr);
5314 gfc_add_block_to_block (&block, &lbound_se.post);
5319 /* Check string lengths if applicable. The check is only really added
5320 to the output code if -fbounds-check is enabled. */
5321 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5323 gcc_assert (expr2->ts.type == BT_CHARACTER);
5324 gcc_assert (strlen_lhs && strlen_rhs);
5325 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5326 strlen_lhs, strlen_rhs, &block);
5329 /* If rank remapping was done, check with -fcheck=bounds that
5330 the target is at least as large as the pointer. */
5331 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5337 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5338 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5340 lsize = gfc_evaluate_now (lsize, &block);
5341 rsize = gfc_evaluate_now (rsize, &block);
5342 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5345 msg = _("Target of rank remapping is too small (%ld < %ld)");
5346 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5350 gfc_add_block_to_block (&block, &lse.post);
5352 gfc_add_block_to_block (&block, &rse.post);
5355 return gfc_finish_block (&block);
5359 /* Makes sure se is suitable for passing as a function string parameter. */
5360 /* TODO: Need to check all callers of this function. It may be abused. */
5363 gfc_conv_string_parameter (gfc_se * se)
5367 if (TREE_CODE (se->expr) == STRING_CST)
5369 type = TREE_TYPE (TREE_TYPE (se->expr));
5370 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5374 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5376 if (TREE_CODE (se->expr) != INDIRECT_REF)
5378 type = TREE_TYPE (se->expr);
5379 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5383 type = gfc_get_character_type_len (gfc_default_character_kind,
5385 type = build_pointer_type (type);
5386 se->expr = gfc_build_addr_expr (type, se->expr);
5390 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5394 /* Generate code for assignment of scalar variables. Includes character
5395 strings and derived types with allocatable components.
5396 If you know that the LHS has no allocations, set dealloc to false. */
5399 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5400 bool l_is_temp, bool r_is_var, bool dealloc)
5406 gfc_init_block (&block);
5408 if (ts.type == BT_CHARACTER)
5413 if (lse->string_length != NULL_TREE)
5415 gfc_conv_string_parameter (lse);
5416 gfc_add_block_to_block (&block, &lse->pre);
5417 llen = lse->string_length;
5420 if (rse->string_length != NULL_TREE)
5422 gcc_assert (rse->string_length != NULL_TREE);
5423 gfc_conv_string_parameter (rse);
5424 gfc_add_block_to_block (&block, &rse->pre);
5425 rlen = rse->string_length;
5428 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5429 rse->expr, ts.kind);
5431 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5435 /* Are the rhs and the lhs the same? */
5438 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5439 gfc_build_addr_expr (NULL_TREE, lse->expr),
5440 gfc_build_addr_expr (NULL_TREE, rse->expr));
5441 cond = gfc_evaluate_now (cond, &lse->pre);
5444 /* Deallocate the lhs allocated components as long as it is not
5445 the same as the rhs. This must be done following the assignment
5446 to prevent deallocating data that could be used in the rhs
5448 if (!l_is_temp && dealloc)
5450 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5451 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5453 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5455 gfc_add_expr_to_block (&lse->post, tmp);
5458 gfc_add_block_to_block (&block, &rse->pre);
5459 gfc_add_block_to_block (&block, &lse->pre);
5461 gfc_add_modify (&block, lse->expr,
5462 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5464 /* Do a deep copy if the rhs is a variable, if it is not the
5468 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5469 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5471 gfc_add_expr_to_block (&block, tmp);
5474 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5476 gfc_add_block_to_block (&block, &lse->pre);
5477 gfc_add_block_to_block (&block, &rse->pre);
5478 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5479 TREE_TYPE (lse->expr), rse->expr);
5480 gfc_add_modify (&block, lse->expr, tmp);
5484 gfc_add_block_to_block (&block, &lse->pre);
5485 gfc_add_block_to_block (&block, &rse->pre);
5487 gfc_add_modify (&block, lse->expr,
5488 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5491 gfc_add_block_to_block (&block, &lse->post);
5492 gfc_add_block_to_block (&block, &rse->post);
5494 return gfc_finish_block (&block);
5498 /* There are quite a lot of restrictions on the optimisation in using an
5499 array function assign without a temporary. */
5502 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5505 bool seen_array_ref;
5507 gfc_symbol *sym = expr1->symtree->n.sym;
5509 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5510 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5513 /* Elemental functions are scalarized so that they don't need a
5514 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5515 they would need special treatment in gfc_trans_arrayfunc_assign. */
5516 if (expr2->value.function.esym != NULL
5517 && expr2->value.function.esym->attr.elemental)
5520 /* Need a temporary if rhs is not FULL or a contiguous section. */
5521 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5524 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5525 if (gfc_ref_needs_temporary_p (expr1->ref))
5528 /* Functions returning pointers or allocatables need temporaries. */
5529 c = expr2->value.function.esym
5530 ? (expr2->value.function.esym->attr.pointer
5531 || expr2->value.function.esym->attr.allocatable)
5532 : (expr2->symtree->n.sym->attr.pointer
5533 || expr2->symtree->n.sym->attr.allocatable);
5537 /* Character array functions need temporaries unless the
5538 character lengths are the same. */
5539 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5541 if (expr1->ts.u.cl->length == NULL
5542 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5545 if (expr2->ts.u.cl->length == NULL
5546 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5549 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5550 expr2->ts.u.cl->length->value.integer) != 0)
5554 /* Check that no LHS component references appear during an array
5555 reference. This is needed because we do not have the means to
5556 span any arbitrary stride with an array descriptor. This check
5557 is not needed for the rhs because the function result has to be
5559 seen_array_ref = false;
5560 for (ref = expr1->ref; ref; ref = ref->next)
5562 if (ref->type == REF_ARRAY)
5563 seen_array_ref= true;
5564 else if (ref->type == REF_COMPONENT && seen_array_ref)
5568 /* Check for a dependency. */
5569 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5570 expr2->value.function.esym,
5571 expr2->value.function.actual,
5575 /* If we have reached here with an intrinsic function, we do not
5576 need a temporary except in the particular case that reallocation
5577 on assignment is active and the lhs is allocatable and a target. */
5578 if (expr2->value.function.isym)
5579 return (gfc_option.flag_realloc_lhs
5580 && sym->attr.allocatable
5581 && sym->attr.target);
5583 /* If the LHS is a dummy, we need a temporary if it is not
5585 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5588 /* If the lhs has been host_associated, is in common, a pointer or is
5589 a target and the function is not using a RESULT variable, aliasing
5590 can occur and a temporary is needed. */
5591 if ((sym->attr.host_assoc
5592 || sym->attr.in_common
5593 || sym->attr.pointer
5594 || sym->attr.cray_pointee
5595 || sym->attr.target)
5596 && expr2->symtree != NULL
5597 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5600 /* A PURE function can unconditionally be called without a temporary. */
5601 if (expr2->value.function.esym != NULL
5602 && expr2->value.function.esym->attr.pure)
5605 /* Implicit_pure functions are those which could legally be declared
5607 if (expr2->value.function.esym != NULL
5608 && expr2->value.function.esym->attr.implicit_pure)
5611 if (!sym->attr.use_assoc
5612 && !sym->attr.in_common
5613 && !sym->attr.pointer
5614 && !sym->attr.target
5615 && !sym->attr.cray_pointee
5616 && expr2->value.function.esym)
5618 /* A temporary is not needed if the function is not contained and
5619 the variable is local or host associated and not a pointer or
5621 if (!expr2->value.function.esym->attr.contained)
5624 /* A temporary is not needed if the lhs has never been host
5625 associated and the procedure is contained. */
5626 else if (!sym->attr.host_assoc)
5629 /* A temporary is not needed if the variable is local and not
5630 a pointer, a target or a result. */
5632 && expr2->value.function.esym->ns == sym->ns->parent)
5636 /* Default to temporary use. */
5641 /* Provide the loop info so that the lhs descriptor can be built for
5642 reallocatable assignments from extrinsic function calls. */
5645 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
5648 /* Signal that the function call should not be made by
5649 gfc_conv_loop_setup. */
5650 se->ss->is_alloc_lhs = 1;
5651 gfc_init_loopinfo (loop);
5652 gfc_add_ss_to_loop (loop, *ss);
5653 gfc_add_ss_to_loop (loop, se->ss);
5654 gfc_conv_ss_startstride (loop);
5655 gfc_conv_loop_setup (loop, where);
5656 gfc_copy_loopinfo_to_se (se, loop);
5657 gfc_add_block_to_block (&se->pre, &loop->pre);
5658 gfc_add_block_to_block (&se->pre, &loop->post);
5659 se->ss->is_alloc_lhs = 0;
5663 /* For Assignment to a reallocatable lhs from intrinsic functions,
5664 replace the se.expr (ie. the result) with a temporary descriptor.
5665 Null the data field so that the library allocates space for the
5666 result. Free the data of the original descriptor after the function,
5667 in case it appears in an argument expression and transfer the
5668 result to the original descriptor. */
5671 fcncall_realloc_result (gfc_se *se, int rank)
5679 /* Use the allocation done by the library. Substitute the lhs
5680 descriptor with a copy, whose data field is nulled.*/
5681 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5682 /* Unallocated, the descriptor does not have a dtype. */
5683 tmp = gfc_conv_descriptor_dtype (desc);
5684 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5685 res_desc = gfc_evaluate_now (desc, &se->pre);
5686 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
5687 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
5689 /* Free the lhs after the function call and copy the result to
5690 the lhs descriptor. */
5691 tmp = gfc_conv_descriptor_data_get (desc);
5692 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5693 gfc_add_expr_to_block (&se->post, tmp);
5694 gfc_add_modify (&se->post, desc, res_desc);
5696 offset = gfc_index_zero_node;
5697 tmp = gfc_index_one_node;
5698 /* Now reset the bounds from zero based to unity based. */
5699 for (n = 0 ; n < rank; n++)
5701 /* Accumulate the offset. */
5702 offset = fold_build2_loc (input_location, MINUS_EXPR,
5703 gfc_array_index_type,
5705 /* Now do the bounds. */
5706 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5707 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5708 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5709 gfc_array_index_type,
5710 tmp, gfc_index_one_node);
5711 gfc_conv_descriptor_lbound_set (&se->post, desc,
5713 gfc_index_one_node);
5714 gfc_conv_descriptor_ubound_set (&se->post, desc,
5715 gfc_rank_cst[n], tmp);
5717 /* The extent for the next contribution to offset. */
5718 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5719 gfc_array_index_type,
5720 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5721 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5722 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5723 gfc_array_index_type,
5724 tmp, gfc_index_one_node);
5726 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5731 /* Try to translate array(:) = func (...), where func is a transformational
5732 array function, without using a temporary. Returns NULL if this isn't the
5736 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5740 gfc_component *comp = NULL;
5743 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5746 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5748 gcc_assert (expr2->value.function.isym
5749 || (gfc_is_proc_ptr_comp (expr2, &comp)
5750 && comp && comp->attr.dimension)
5751 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5752 && expr2->value.function.esym->result->attr.dimension));
5754 ss = gfc_walk_expr (expr1);
5755 gcc_assert (ss != gfc_ss_terminator);
5756 gfc_init_se (&se, NULL);
5757 gfc_start_block (&se.pre);
5758 se.want_pointer = 1;
5760 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5762 if (expr1->ts.type == BT_DERIVED
5763 && expr1->ts.u.derived->attr.alloc_comp)
5766 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5768 gfc_add_expr_to_block (&se.pre, tmp);
5771 se.direct_byref = 1;
5772 se.ss = gfc_walk_expr (expr2);
5773 gcc_assert (se.ss != gfc_ss_terminator);
5775 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5776 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5777 Clearly, this cannot be done for an allocatable function result, since
5778 the shape of the result is unknown and, in any case, the function must
5779 correctly take care of the reallocation internally. For intrinsic
5780 calls, the array data is freed and the library takes care of allocation.
5781 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5783 if (gfc_option.flag_realloc_lhs
5784 && gfc_is_reallocatable_lhs (expr1)
5785 && !gfc_expr_attr (expr1).codimension
5786 && !gfc_is_coindexed (expr1)
5787 && !(expr2->value.function.esym
5788 && expr2->value.function.esym->result->attr.allocatable))
5790 if (!expr2->value.function.isym)
5792 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
5793 ss->is_alloc_lhs = 1;
5796 fcncall_realloc_result (&se, expr1->rank);
5799 gfc_conv_function_expr (&se, expr2);
5800 gfc_add_block_to_block (&se.pre, &se.post);
5802 return gfc_finish_block (&se.pre);
5806 /* Try to efficiently translate array(:) = 0. Return NULL if this
5810 gfc_trans_zero_assign (gfc_expr * expr)
5812 tree dest, len, type;
5816 sym = expr->symtree->n.sym;
5817 dest = gfc_get_symbol_decl (sym);
5819 type = TREE_TYPE (dest);
5820 if (POINTER_TYPE_P (type))
5821 type = TREE_TYPE (type);
5822 if (!GFC_ARRAY_TYPE_P (type))
5825 /* Determine the length of the array. */
5826 len = GFC_TYPE_ARRAY_SIZE (type);
5827 if (!len || TREE_CODE (len) != INTEGER_CST)
5830 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5831 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5832 fold_convert (gfc_array_index_type, tmp));
5834 /* If we are zeroing a local array avoid taking its address by emitting
5836 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5837 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5838 dest, build_constructor (TREE_TYPE (dest), NULL));
5840 /* Convert arguments to the correct types. */
5841 dest = fold_convert (pvoid_type_node, dest);
5842 len = fold_convert (size_type_node, len);
5844 /* Construct call to __builtin_memset. */
5845 tmp = build_call_expr_loc (input_location,
5846 builtin_decl_explicit (BUILT_IN_MEMSET),
5847 3, dest, integer_zero_node, len);
5848 return fold_convert (void_type_node, tmp);
5852 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5853 that constructs the call to __builtin_memcpy. */
5856 gfc_build_memcpy_call (tree dst, tree src, tree len)
5860 /* Convert arguments to the correct types. */
5861 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5862 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5864 dst = fold_convert (pvoid_type_node, dst);
5866 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5867 src = gfc_build_addr_expr (pvoid_type_node, src);
5869 src = fold_convert (pvoid_type_node, src);
5871 len = fold_convert (size_type_node, len);
5873 /* Construct call to __builtin_memcpy. */
5874 tmp = build_call_expr_loc (input_location,
5875 builtin_decl_explicit (BUILT_IN_MEMCPY),
5877 return fold_convert (void_type_node, tmp);
5881 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5882 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5883 source/rhs, both are gfc_full_array_ref_p which have been checked for
5887 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5889 tree dst, dlen, dtype;
5890 tree src, slen, stype;
5893 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5894 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5896 dtype = TREE_TYPE (dst);
5897 if (POINTER_TYPE_P (dtype))
5898 dtype = TREE_TYPE (dtype);
5899 stype = TREE_TYPE (src);
5900 if (POINTER_TYPE_P (stype))
5901 stype = TREE_TYPE (stype);
5903 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5906 /* Determine the lengths of the arrays. */
5907 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5908 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5910 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5911 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5912 dlen, fold_convert (gfc_array_index_type, tmp));
5914 slen = GFC_TYPE_ARRAY_SIZE (stype);
5915 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5917 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5918 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5919 slen, fold_convert (gfc_array_index_type, tmp));
5921 /* Sanity check that they are the same. This should always be
5922 the case, as we should already have checked for conformance. */
5923 if (!tree_int_cst_equal (slen, dlen))
5926 return gfc_build_memcpy_call (dst, src, dlen);
5930 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5931 this can't be done. EXPR1 is the destination/lhs for which
5932 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5935 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5937 unsigned HOST_WIDE_INT nelem;
5943 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5947 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5948 dtype = TREE_TYPE (dst);
5949 if (POINTER_TYPE_P (dtype))
5950 dtype = TREE_TYPE (dtype);
5951 if (!GFC_ARRAY_TYPE_P (dtype))
5954 /* Determine the lengths of the array. */
5955 len = GFC_TYPE_ARRAY_SIZE (dtype);
5956 if (!len || TREE_CODE (len) != INTEGER_CST)
5959 /* Confirm that the constructor is the same size. */
5960 if (compare_tree_int (len, nelem) != 0)
5963 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5964 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5965 fold_convert (gfc_array_index_type, tmp));
5967 stype = gfc_typenode_for_spec (&expr2->ts);
5968 src = gfc_build_constant_array_constructor (expr2, stype);
5970 stype = TREE_TYPE (src);
5971 if (POINTER_TYPE_P (stype))
5972 stype = TREE_TYPE (stype);
5974 return gfc_build_memcpy_call (dst, src, len);
5978 /* Tells whether the expression is to be treated as a variable reference. */
5981 expr_is_variable (gfc_expr *expr)
5985 if (expr->expr_type == EXPR_VARIABLE)
5988 arg = gfc_get_noncopying_intrinsic_argument (expr);
5991 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5992 return expr_is_variable (arg);
5999 /* Is the lhs OK for automatic reallocation? */
6002 is_scalar_reallocatable_lhs (gfc_expr *expr)
6006 /* An allocatable variable with no reference. */
6007 if (expr->symtree->n.sym->attr.allocatable
6011 /* All that can be left are allocatable components. */
6012 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6013 && expr->symtree->n.sym->ts.type != BT_CLASS)
6014 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6017 /* Find an allocatable component ref last. */
6018 for (ref = expr->ref; ref; ref = ref->next)
6019 if (ref->type == REF_COMPONENT
6021 && ref->u.c.component->attr.allocatable)
6028 /* Allocate or reallocate scalar lhs, as necessary. */
6031 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6045 if (!expr1 || expr1->rank)
6048 if (!expr2 || expr2->rank)
6051 /* Since this is a scalar lhs, we can afford to do this. That is,
6052 there is no risk of side effects being repeated. */
6053 gfc_init_se (&lse, NULL);
6054 lse.want_pointer = 1;
6055 gfc_conv_expr (&lse, expr1);
6057 jump_label1 = gfc_build_label_decl (NULL_TREE);
6058 jump_label2 = gfc_build_label_decl (NULL_TREE);
6060 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6061 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6062 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6064 tmp = build3_v (COND_EXPR, cond,
6065 build1_v (GOTO_EXPR, jump_label1),
6066 build_empty_stmt (input_location));
6067 gfc_add_expr_to_block (block, tmp);
6069 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6071 /* Use the rhs string length and the lhs element size. */
6072 size = string_length;
6073 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6074 tmp = TYPE_SIZE_UNIT (tmp);
6075 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6076 TREE_TYPE (tmp), tmp,
6077 fold_convert (TREE_TYPE (tmp), size));
6081 /* Otherwise use the length in bytes of the rhs. */
6082 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6083 size_in_bytes = size;
6086 tmp = build_call_expr_loc (input_location,
6087 builtin_decl_explicit (BUILT_IN_MALLOC),
6089 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6090 gfc_add_modify (block, lse.expr, tmp);
6091 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6093 /* Deferred characters need checking for lhs and rhs string
6094 length. Other deferred parameter variables will have to
6096 tmp = build1_v (GOTO_EXPR, jump_label2);
6097 gfc_add_expr_to_block (block, tmp);
6099 tmp = build1_v (LABEL_EXPR, jump_label1);
6100 gfc_add_expr_to_block (block, tmp);
6102 /* For a deferred length character, reallocate if lengths of lhs and
6103 rhs are different. */
6104 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6106 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6107 expr1->ts.u.cl->backend_decl, size);
6108 /* Jump past the realloc if the lengths are the same. */
6109 tmp = build3_v (COND_EXPR, cond,
6110 build1_v (GOTO_EXPR, jump_label2),
6111 build_empty_stmt (input_location));
6112 gfc_add_expr_to_block (block, tmp);
6113 tmp = build_call_expr_loc (input_location,
6114 builtin_decl_explicit (BUILT_IN_REALLOC),
6115 2, fold_convert (pvoid_type_node, lse.expr),
6117 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6118 gfc_add_modify (block, lse.expr, tmp);
6119 tmp = build1_v (LABEL_EXPR, jump_label2);
6120 gfc_add_expr_to_block (block, tmp);
6122 /* Update the lhs character length. */
6123 size = string_length;
6124 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6129 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6130 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6131 init_flag indicates initialization expressions and dealloc that no
6132 deallocate prior assignment is needed (if in doubt, set true). */
6135 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6141 gfc_ss *lss_section;
6148 bool scalar_to_array;
6153 /* Assignment of the form lhs = rhs. */
6154 gfc_start_block (&block);
6156 gfc_init_se (&lse, NULL);
6157 gfc_init_se (&rse, NULL);
6160 lss = gfc_walk_expr (expr1);
6161 if (gfc_is_reallocatable_lhs (expr1)
6162 && !(expr2->expr_type == EXPR_FUNCTION
6163 && expr2->value.function.isym != NULL))
6164 lss->is_alloc_lhs = 1;
6166 if (lss != gfc_ss_terminator)
6168 /* The assignment needs scalarization. */
6171 /* Find a non-scalar SS from the lhs. */
6172 while (lss_section != gfc_ss_terminator
6173 && lss_section->info->type != GFC_SS_SECTION)
6174 lss_section = lss_section->next;
6176 gcc_assert (lss_section != gfc_ss_terminator);
6178 /* Initialize the scalarizer. */
6179 gfc_init_loopinfo (&loop);
6182 rss = gfc_walk_expr (expr2);
6183 if (rss == gfc_ss_terminator)
6184 /* The rhs is scalar. Add a ss for the expression. */
6185 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6187 /* Associate the SS with the loop. */
6188 gfc_add_ss_to_loop (&loop, lss);
6189 gfc_add_ss_to_loop (&loop, rss);
6191 /* Calculate the bounds of the scalarization. */
6192 gfc_conv_ss_startstride (&loop);
6193 /* Enable loop reversal. */
6194 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6195 loop.reverse[n] = GFC_ENABLE_REVERSE;
6196 /* Resolve any data dependencies in the statement. */
6197 gfc_conv_resolve_dependencies (&loop, lss, rss);
6198 /* Setup the scalarizing loops. */
6199 gfc_conv_loop_setup (&loop, &expr2->where);
6201 /* Setup the gfc_se structures. */
6202 gfc_copy_loopinfo_to_se (&lse, &loop);
6203 gfc_copy_loopinfo_to_se (&rse, &loop);
6206 gfc_mark_ss_chain_used (rss, 1);
6207 if (loop.temp_ss == NULL)
6210 gfc_mark_ss_chain_used (lss, 1);
6214 lse.ss = loop.temp_ss;
6215 gfc_mark_ss_chain_used (lss, 3);
6216 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6219 /* Allow the scalarizer to workshare array assignments. */
6220 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6221 ompws_flags |= OMPWS_SCALARIZER_WS;
6223 /* Start the scalarized loop body. */
6224 gfc_start_scalarized_body (&loop, &body);
6227 gfc_init_block (&body);
6229 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6231 /* Translate the expression. */
6232 gfc_conv_expr (&rse, expr2);
6234 /* Stabilize a string length for temporaries. */
6235 if (expr2->ts.type == BT_CHARACTER)
6236 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6238 string_length = NULL_TREE;
6242 gfc_conv_tmp_array_ref (&lse);
6243 if (expr2->ts.type == BT_CHARACTER)
6244 lse.string_length = string_length;
6247 gfc_conv_expr (&lse, expr1);
6249 /* Assignments of scalar derived types with allocatable components
6250 to arrays must be done with a deep copy and the rhs temporary
6251 must have its components deallocated afterwards. */
6252 scalar_to_array = (expr2->ts.type == BT_DERIVED
6253 && expr2->ts.u.derived->attr.alloc_comp
6254 && !expr_is_variable (expr2)
6255 && !gfc_is_constant_expr (expr2)
6256 && expr1->rank && !expr2->rank);
6257 if (scalar_to_array && dealloc)
6259 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6260 gfc_add_expr_to_block (&loop.post, tmp);
6263 /* For a deferred character length function, the function call must
6264 happen before the (re)allocation of the lhs, otherwise the character
6265 length of the result is not known. */
6266 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6267 || (expr2->expr_type == EXPR_COMPCALL)
6268 || (expr2->expr_type == EXPR_PPC))
6269 && expr2->ts.deferred);
6270 if (gfc_option.flag_realloc_lhs
6271 && expr2->ts.type == BT_CHARACTER
6272 && (def_clen_func || expr2->expr_type == EXPR_OP)
6273 && expr1->ts.deferred)
6274 gfc_add_block_to_block (&block, &rse.pre);
6276 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6277 l_is_temp || init_flag,
6278 expr_is_variable (expr2) || scalar_to_array
6279 || expr2->expr_type == EXPR_ARRAY, dealloc);
6280 gfc_add_expr_to_block (&body, tmp);
6282 if (lss == gfc_ss_terminator)
6284 /* F2003: Add the code for reallocation on assignment. */
6285 if (gfc_option.flag_realloc_lhs
6286 && is_scalar_reallocatable_lhs (expr1))
6287 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6290 /* Use the scalar assignment as is. */
6291 gfc_add_block_to_block (&block, &body);
6295 gcc_assert (lse.ss == gfc_ss_terminator
6296 && rse.ss == gfc_ss_terminator);
6300 gfc_trans_scalarized_loop_boundary (&loop, &body);
6302 /* We need to copy the temporary to the actual lhs. */
6303 gfc_init_se (&lse, NULL);
6304 gfc_init_se (&rse, NULL);
6305 gfc_copy_loopinfo_to_se (&lse, &loop);
6306 gfc_copy_loopinfo_to_se (&rse, &loop);
6308 rse.ss = loop.temp_ss;
6311 gfc_conv_tmp_array_ref (&rse);
6312 gfc_conv_expr (&lse, expr1);
6314 gcc_assert (lse.ss == gfc_ss_terminator
6315 && rse.ss == gfc_ss_terminator);
6317 if (expr2->ts.type == BT_CHARACTER)
6318 rse.string_length = string_length;
6320 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6321 false, false, dealloc);
6322 gfc_add_expr_to_block (&body, tmp);
6325 /* F2003: Allocate or reallocate lhs of allocatable array. */
6326 if (gfc_option.flag_realloc_lhs
6327 && gfc_is_reallocatable_lhs (expr1)
6328 && !gfc_expr_attr (expr1).codimension
6329 && !gfc_is_coindexed (expr1))
6331 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6332 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6333 if (tmp != NULL_TREE)
6334 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6337 /* Generate the copying loops. */
6338 gfc_trans_scalarizing_loops (&loop, &body);
6340 /* Wrap the whole thing up. */
6341 gfc_add_block_to_block (&block, &loop.pre);
6342 gfc_add_block_to_block (&block, &loop.post);
6344 gfc_cleanup_loop (&loop);
6347 return gfc_finish_block (&block);
6351 /* Check whether EXPR is a copyable array. */
6354 copyable_array_p (gfc_expr * expr)
6356 if (expr->expr_type != EXPR_VARIABLE)
6359 /* First check it's an array. */
6360 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6363 if (!gfc_full_array_ref_p (expr->ref, NULL))
6366 /* Next check that it's of a simple enough type. */
6367 switch (expr->ts.type)
6379 return !expr->ts.u.derived->attr.alloc_comp;
6388 /* Translate an assignment. */
6391 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6396 /* Special case a single function returning an array. */
6397 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6399 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6404 /* Special case assigning an array to zero. */
6405 if (copyable_array_p (expr1)
6406 && is_zero_initializer_p (expr2))
6408 tmp = gfc_trans_zero_assign (expr1);
6413 /* Special case copying one array to another. */
6414 if (copyable_array_p (expr1)
6415 && copyable_array_p (expr2)
6416 && gfc_compare_types (&expr1->ts, &expr2->ts)
6417 && !gfc_check_dependency (expr1, expr2, 0))
6419 tmp = gfc_trans_array_copy (expr1, expr2);
6424 /* Special case initializing an array from a constant array constructor. */
6425 if (copyable_array_p (expr1)
6426 && expr2->expr_type == EXPR_ARRAY
6427 && gfc_compare_types (&expr1->ts, &expr2->ts))
6429 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6434 /* Fallback to the scalarizer to generate explicit loops. */
6435 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6439 gfc_trans_init_assign (gfc_code * code)
6441 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6445 gfc_trans_assign (gfc_code * code)
6447 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6451 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6452 A MEMCPY is needed to copy the full data from the default initializer
6453 of the dynamic type. */
6456 gfc_trans_class_init_assign (gfc_code *code)
6460 gfc_se dst,src,memsz;
6461 gfc_expr *lhs,*rhs,*sz;
6463 gfc_start_block (&block);
6465 lhs = gfc_copy_expr (code->expr1);
6466 gfc_add_data_component (lhs);
6468 rhs = gfc_copy_expr (code->expr1);
6469 gfc_add_vptr_component (rhs);
6471 /* Make sure that the component backend_decls have been built, which
6472 will not have happened if the derived types concerned have not
6474 gfc_get_derived_type (rhs->ts.u.derived);
6475 gfc_add_def_init_component (rhs);
6477 sz = gfc_copy_expr (code->expr1);
6478 gfc_add_vptr_component (sz);
6479 gfc_add_size_component (sz);
6481 gfc_init_se (&dst, NULL);
6482 gfc_init_se (&src, NULL);
6483 gfc_init_se (&memsz, NULL);
6484 gfc_conv_expr (&dst, lhs);
6485 gfc_conv_expr (&src, rhs);
6486 gfc_conv_expr (&memsz, sz);
6487 gfc_add_block_to_block (&block, &src.pre);
6488 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6489 gfc_add_expr_to_block (&block, tmp);
6491 return gfc_finish_block (&block);
6495 /* Translate an assignment to a CLASS object
6496 (pointer or ordinary assignment). */
6499 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6506 gfc_start_block (&block);
6508 if (expr2->ts.type != BT_CLASS)
6510 /* Insert an additional assignment which sets the '_vptr' field. */
6511 gfc_symbol *vtab = NULL;
6514 lhs = gfc_copy_expr (expr1);
6515 gfc_add_vptr_component (lhs);
6517 if (expr2->ts.type == BT_DERIVED)
6518 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6519 else if (expr2->expr_type == EXPR_NULL)
6520 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6523 rhs = gfc_get_expr ();
6524 rhs->expr_type = EXPR_VARIABLE;
6525 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6529 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6530 gfc_add_expr_to_block (&block, tmp);
6532 gfc_free_expr (lhs);
6533 gfc_free_expr (rhs);
6536 /* Do the actual CLASS assignment. */
6537 if (expr2->ts.type == BT_CLASS)
6540 gfc_add_data_component (expr1);
6542 if (op == EXEC_ASSIGN)
6543 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6544 else if (op == EXEC_POINTER_ASSIGN)
6545 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6549 gfc_add_expr_to_block (&block, tmp);
6551 return gfc_finish_block (&block);